rhi
/
gallery
1
0
Fork 0
Code Issues 5 Pull Requests 1 Releases Wiki Activity

replace OverloadedLabels with OverloadedRecordDot

This commit is contained in:
rhiannon morris 2024-07-11 22:00:00 +02:00
parent cd5801dd7d
commit 28520eb443
8 changed files with 126 additions and 138 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
make-pages/Depend.hs
View File

@ -29,12 +29,12 @@ dependSingle' yamlDir indexFile info prefix build nsfw =
[b|$page: $deps $indexFile $$(MAKEPAGES)|] [b|$page: $deps $indexFile $$(MAKEPAGES)|]
where where
images = images =
maybe [] (toList . #all) $ maybe [] (toList . allImages) $
if nsfw then Just $ #images info else #sfwImages info if nsfw then Just $ info.images else sfwImages info
paths = map #path images paths = map (.path) images
dls = mapMaybe #download images dls = mapMaybe (.download) images
extras = #extras info extras = info.extras
dir = build </> prefix </> yamlDir dir = build </> prefix </> yamlDir
page = dir </> "index.html" page = dir </> "index.html"
@ -71,9 +71,9 @@ dependGallery' (GalleryInfo {prefix, filters})
$incs $incs
|] |]
where where
infos = filter (matchFilters filters . #second) infos' infos = filter (matchFilters filters . snd) infos'
files = map #first infos files = map fst infos
files' = unwords $ map (data_ </>) files files' = unwords $ map (data_ </>) files
page d = build </> prefix </> takeDirectory d </> "index.html" page d = build </> prefix </> takeDirectory d </> "index.html"
@ -120,4 +120,4 @@ filtersToFlags (GalleryFilters {nsfw}) =
case nsfw of NoNsfw -> ""; _ -> "-n" case nsfw of NoNsfw -> ""; _ -> "-n"
thumbnail :: Info -> FilePath thumbnail :: Info -> FilePath
thumbnail = fromMaybe (error "no thumbnail or sfw images") . #thumb thumbnail = fromMaybe (error "no thumbnail or sfw images") . thumb

35
make-pages/GalleryPage.hs
View File

@ -91,21 +91,21 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
infosByYear :: [(Int, [(FilePath, Info)])] infosByYear :: [(Int, [(FilePath, Info)])]
infosByYear = infos & infosByYear = infos &
filter (not . #unlisted . snd) & filter (not . (.unlisted) . snd) &
sortOn (Down . compareKeyFor nsfw . snd) & sortOn (Down . compareKeyFor nsfw . snd) &
groupOnKey (\(_, i) -> #latestYear i nsfw) groupOnKey (\(_, i) -> latestYearFor nsfw i)
undir = joinPath (replicate (length (splitPath prefix)) "..") undir = joinPath (replicate (length (splitPath prefix)) "..")
allTags = infos allTags = infos
& concatMap (map (,1) . tagsFor nsfw . #second) & concatMap (map (,1) . tagsFor nsfw . snd)
& HashMap.fromListWith (+) & HashMap.toList & HashMap.fromListWith (+) & HashMap.toList
& sort & sort
requireFilters = map (uncurry $ makeFilter "require" mempty) allTags requireFilters = map (uncurry $ makeFilter "require" mempty) allTags
excludeFilters = map (uncurry $ makeFilter "exclude" hidden) allTags excludeFilters = map (uncurry $ makeFilter "exclude" hidden) allTags
nsfw = #nsfw filters /= NoNsfw nsfw = filters.nsfw /= NoNsfw
url = [b|$root/$prefix|] url = [b|$root/$prefix|]
imagepath0 imagepath0
@ -153,22 +153,21 @@ makeItem nsfw file info@(Info {bg}) = [b|@0
<li class="item post$nsfw'" data-year=$year' data-updated="$updated'" <li class="item post$nsfw'" data-year=$year' data-updated="$updated'"
data-tags="$tags'"> data-tags="$tags'">
<a href="$dir"> <a href="$dir">
<img src="$thumb" loading=lazy$bgStyle <img src="$thumbnail" loading=lazy$bgStyle
width=200 height=200 width=200 height=200
title="$tooltip"> title="$tooltip">
</a> </a>
|] |]
where where
title = fromMaybe (#title info) $ #galleryTitle info title = fromMaybe info.title $ info.galleryTitle
dir = takeDirectory file dir = takeDirectory file
thumb = getThumb dir info thumbnail = getThumb dir info
nsfw' = if nsfw && #anyNsfw info then [b| nsfw|] else "" nsfw' = if nsfw && anyNsfw info then [b| nsfw|] else ""
tags' = fold $ intersperse ";" $ map fromText $ tagsFor nsfw info tags' = fold $ intersperse ";" $ map fromText $ tagsFor nsfw info
date = #latestDate info nsfw date = latestDateFor nsfw info
date' = formatTooltip date date' = formatTooltip date
year' = #year date year' = date.year
updated' = if #updated info nsfw then [b|true|] else [b|false|] updated' = if hasUpdatesFor nsfw info then [b|true|] else [b|false|]
bgStyle = case bg of Other col -> [b| style="background: $col"|]; _ -> "" bgStyle = case bg of Other col -> [b| style="background: $col"|]; _ -> ""
tooltip = tooltip = [b|$title ($upd$date')|]
let upd = if #updated info nsfw then "updated " else "" :: Builder in where upd = if hasUpdatesFor nsfw info then "updated " else "" :: Builder
[b|$title ($upd$date')|]

143
make-pages/Info.hs
View File

@ -3,20 +3,31 @@
{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-orphans #-}
module Info module Info
(Info (..), (Info (..),
tagsFor, descFor, imagesFor, linksFor, updatesFor, lastUpdate, anySfw, anyNsfw, allSfw, allNsfw,
allImages, sfwImages, nsfwImages,
thumb, latestDateFor, latestYearFor,
sfwLinks, nsfwLinks, sfwUpdates, nsfwUpdates,
updatesFor, hasUpdatesFor, lastUpdateFor,
tagsFor, descFor, imagesFor, linksFor,
CompareKey (..), compareKeyFor, compareFor, sortFor, CompareKey (..), compareKeyFor, compareFor, sortFor,
Artist (..), Images' (..), Images, Image (..), Desc (..), DescField (..), Artist (..), Images' (..), Images, Image (..), Desc (..), DescField (..),
Link (..), Update (..), Bg (..), Link (..), Update (..), Bg (..),
GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..), GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..),
IndexInfo (..),
readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters, readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters,
IndexInfo (..),
NoThumb (..), getThumb, thumbFile, pageFile, bigFile, NoThumb (..), getThumb, thumbFile, pageFile, bigFile,
-- ** Reexports -- ** Reexports
Date (..), Day (..), Text, NonEmpty (..)) Date (..), Day (..), Text, NonEmpty (..))
where where
import Date import Date
import Records import GHC.Records
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad
@ -38,7 +49,6 @@ import qualified Data.Text as Text
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=)) import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
import qualified Data.YAML as YAML import qualified Data.YAML as YAML
import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension) import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension)
import Data.Bifunctor (second)
import Data.Semigroup import Data.Semigroup
@ -49,7 +59,7 @@ data Info =
-- e.g. multiple things on the same day might have a,b,c in @sortEx@ to -- e.g. multiple things on the same day might have a,b,c in @sortEx@ to
-- put them in the right order in the gallery -- put them in the right order in the gallery
sortEx :: !Text, sortEx :: !Text,
updates :: ![(Date, [Update])], updates :: ![(Date, NonEmpty Update)],
-- | if false, don't show updated emblem even if @updates@ is non-empty -- | if false, don't show updated emblem even if @updates@ is non-empty
showUpdated :: !Bool, showUpdated :: !Bool,
-- | hide from gallery view -- | hide from gallery view
@ -123,13 +133,13 @@ data Update =
} }
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
instance HasField "sfw" Image Bool where getField = not . #nsfw instance HasField "sfw" Image Bool where getField i = not i.nsfw
instance HasField "sfw" Link Bool where getField = not . #nsfw instance HasField "sfw" Link Bool where getField i = not i.nsfw
instance HasField "sfw" Update Bool where getField = not . #nsfw instance HasField "sfw" Update Bool where getField i = not i.nsfw
instance HasField "all" (Images' a) (NonEmpty a) where allImages :: Images' a -> NonEmpty a
getField (Uncat is) = is allImages (Uncat is) = is
getField (Cat cats) = sconcat $ fmap snd cats allImages (Cat cats) = sconcat $ fmap snd cats
filterNE :: (a -> Bool) -> NonEmpty a -> Maybe (NonEmpty a) filterNE :: (a -> Bool) -> NonEmpty a -> Maybe (NonEmpty a)
filterNE p = nonEmpty . filter p . toList filterNE p = nonEmpty . filter p . toList
@ -142,45 +152,51 @@ filterImages p (Uncat is) = Uncat <$> filterNE p is
filterImages p (Cat cats) = filterImages p (Cat cats) =
fmap Cat $ catMaybesNE $ fmap (traverse $ filterNE p) cats fmap Cat $ catMaybesNE $ fmap (traverse $ filterNE p) cats
instance HasField "sfwImages" Info (Maybe Images) where sfwImages, nsfwImages :: Info -> Maybe Images
getField = filterImages #sfw . #images sfwImages i = filterImages (.sfw) i.images
instance HasField "nsfwImages" Info (Maybe Images) where nsfwImages i = filterImages (.nsfw) i.images
getField = filterImages #nsfw . #images
instance HasField "anySfw" Info Bool where getField = isJust . #sfwImages
instance HasField "anyNsfw" Info Bool where getField = isJust . #nsfwImages
instance HasField "allNsfw" Info Bool where getField = not . #anySfw
instance HasField "allSfw" Info Bool where getField = not . #anyNsfw
instance HasField "sfwLinks" Info [Link] where anySfw, anyNsfw, allSfw, allNsfw :: Info -> Bool
getField = filter #sfw . #links anySfw = isJust . sfwImages
instance HasField "nsfwLinks" Info [Link] where anyNsfw = isJust . nsfwImages
getField = filter #nsfw . #links allSfw = not . anyNsfw
allNsfw = not . anySfw
instance HasField "sfwUpdates" Info [(Date, [Update])] where sfwLinks, nsfwLinks :: Info -> [Link]
getField = filter (not . null) . map (second (filter #sfw)) . #updates sfwLinks i = filter (.sfw) i.links
instance HasField "nsfwUpdates" Info [(Date, [Update])] where nsfwLinks i = filter (.nsfw) i.links
getField = filter (not . null) . map (second (filter #nsfw)) . #updates
instance HasField "thumb" Info (Maybe FilePath) where updatesWith :: (Update -> Bool) -> Info -> [(Date, NonEmpty Update)]
getField (Info {thumb', images}) = updatesWith p i = mapMaybe (traverse $ filterNE p) i.updates
thumb' <|> #path <$> find #sfw (#all images)
instance HasField "mine" Info Bool where getField = isNothing . #artist updatesFor :: Bool -> Info -> [(Date, NonEmpty Update)]
instance HasField "notMine" Info Bool where getField = isJust . #artist updatesFor nsfw = updatesWith \u -> nsfw || u.sfw
instance HasField "latestDate" Info (Bool -> Date) where sfwUpdates, nsfwUpdates :: Info -> [(Date, NonEmpty Update)]
getField info@(Info {date=date₀}) nsfw = sfwUpdates = updatesWith (.sfw)
maximum $ date₀ : mapMaybe relDate (updatesFor nsfw info) nsfwUpdates = updatesWith (.nsfw)
where
relDate (date, us) = date <$ guard (not $ null us || any #ignoreSort us)
instance HasField "latestYear" Info (Bool -> Int) where lastUpdateFor :: Bool -> Info -> Maybe Date
getField info nsfw = #year $ #latestDate info nsfw lastUpdateFor nsfw info = case updatesFor nsfw info of
[] -> Nothing
us -> Just $ fst $ last us
instance HasField "updated" Info (Bool -> Bool) where thumb :: Info -> Maybe FilePath
getField (Info {updates, showUpdated}) nsfw = showUpdated && updated where thumb (Info {thumb', images}) =
updated = if nsfw then not $ null updates else any (any #sfw . snd) updates thumb' <|> (.path) <$> find (.sfw) (allImages images)
latestDateFor :: Bool -> Info -> Date
latestDateFor nsfw i = maximum $ i.date : mapMaybe relDate (updatesFor nsfw i)
where
relDate (date, us) = date <$ guard (not $ null us || any (.ignoreSort) us)
latestYearFor :: Bool -> Info -> Int
latestYearFor nsfw info = (latestDateFor nsfw info).year
hasUpdatesFor :: Bool -> Info -> Bool
hasUpdatesFor i nsfw = not $ null $ updatesFor i nsfw
defDescKey :: Text defDescKey :: Text
defDescKey = "about" defDescKey = "about"
@ -202,8 +218,8 @@ merge fs1 fs2 = go fs1 [] fs2 where
Nothing -> go first (x:unused) xs Nothing -> go first (x:unused) xs
insert [] _ = Nothing insert [] _ = Nothing
insert (x:xs) y = insert (x:xs) y =
if #name x == #name y then if x.name == y.name then
Just $ x {text = #text x <> #text y} : xs Just $ x {text = x.text <> y.text} : xs
else else
(x :) <$> insert xs y (x :) <$> insert xs y
@ -218,26 +234,19 @@ descFor :: Bool -> Info -> Desc
descFor nsfw (Info {desc, nsfwDesc}) = if nsfw then desc <> nsfwDesc else desc descFor nsfw (Info {desc, nsfwDesc}) = if nsfw then desc <> nsfwDesc else desc
tagsFor :: Bool -> Info -> [Text] tagsFor :: Bool -> Info -> [Text]
tagsFor nsfw i = if nsfw then nub (#tags i <> #nsfwTags i) else #tags i tagsFor nsfw i = if nsfw then nub $ i.tags <> i.nsfwTags else i.tags
imagesFor :: Bool -> Info -> Maybe Images imagesFor :: Bool -> Info -> Maybe Images
imagesFor nsfw = if nsfw then Just . #images else #sfwImages imagesFor nsfw i = if nsfw then Just i.images else sfwImages i
linksFor :: Bool -> Info -> [Link] linksFor :: Bool -> Info -> [Link]
linksFor nsfw = if nsfw then #links else #sfwLinks linksFor nsfw i = if nsfw then i.links else sfwLinks i
updatesFor :: Bool -> Info -> [(Date, [Update])]
updatesFor nsfw = if nsfw then #updates else #sfwUpdates
lastUpdate :: Bool -> Info -> Maybe Date
lastUpdate nsfw info =
case updatesFor nsfw info of [] -> Nothing; us -> Just $ fst $ last us
data CompareKey = MkCompareKey !Date !Text !Text data CompareKey = MkCompareKey !Date !Text !Text
deriving (Eq, Ord) deriving (Eq, Ord)
compareKeyFor :: Bool -> Info -> CompareKey compareKeyFor :: Bool -> Info -> CompareKey
compareKeyFor nsfw i = MkCompareKey (#latestDate i nsfw) (#sortEx i) (#title i) compareKeyFor nsfw i = MkCompareKey (latestDateFor nsfw i) i.sortEx i.title
compareFor :: Bool -> Info -> Info -> Ordering compareFor :: Bool -> Info -> Info -> Ordering
compareFor nsfw = comparing $ compareKeyFor nsfw compareFor nsfw = comparing $ compareKeyFor nsfw
@ -252,7 +261,7 @@ instance Show NoThumb where show (NoThumb dir) = "no thumbnail for " ++ dir
getThumb :: FilePath -> Info -> FilePath getThumb :: FilePath -> Info -> FilePath
getThumb dir = getThumb dir =
maybe (throw $ NoThumb dir) (\t -> dir </> thumbFile t) . #thumb maybe (throw $ NoThumb dir) (\t -> dir </> thumbFile t) . thumb
thumbFile :: FilePath -> FilePath thumbFile :: FilePath -> FilePath
thumbFile = addSuffix "_small" thumbFile = addSuffix "_small"
@ -385,9 +394,11 @@ instance FromYAML Link where
pure $ Link {title, url, nsfw} pure $ Link {title, url, nsfw}
updateList :: Maybe (YAML.Node YAML.Pos) -> YAML.Parser [(Date, [Update])] updateList :: Maybe (YAML.Node YAML.Pos) ->
YAML.Parser [(Date, NonEmpty Update)]
updateList = updateList =
maybe (pure []) $ YAML.withMap "updates" $ traverse bodies . Map.toList maybe (pure []) $ YAML.withMap "updates" $
nonEmptys <=< traverse bodies . Map.toList
where where
bodies (date', rest) = (,) <$> parseYAML date' <*> body rest bodies (date', rest) = (,) <$> parseYAML date' <*> body rest
body b = body b =
@ -402,6 +413,8 @@ updateList =
nsfw <- m .:? "nsfw" .!= False nsfw <- m .:? "nsfw" .!= False
ignoreSort <- m .:? "ignore-sort" .!= False ignoreSort <- m .:? "ignore-sort" .!= False
pure $ Update {desc, nsfw, ignoreSort} pure $ Update {desc, nsfw, ignoreSort}
nonEmptys = traverse $ traverse $
maybe (fail "expected non-empty list") pure . nonEmpty
data GalleryInfo = data GalleryInfo =
@ -415,7 +428,7 @@ data GalleryInfo =
deriving (Eq, Show) deriving (Eq, Show)
instance HasField "nsfw" GalleryInfo Bool where instance HasField "nsfw" GalleryInfo Bool where
getField g = #nsfw (#filters g) /= NoNsfw getField g = g.filters.nsfw /= NoNsfw
data GalleryFilters = data GalleryFilters =
GalleryFilters { GalleryFilters {
@ -434,8 +447,8 @@ readNsfwFilter "all" = pure AllN
readNsfwFilter _ = empty readNsfwFilter _ = empty
matchNsfw :: NsfwFilter -> Info -> Bool matchNsfw :: NsfwFilter -> Info -> Bool
matchNsfw NoNsfw i = #anySfw i && not (#nsfwOnly i) matchNsfw NoNsfw i = anySfw i && not i.nsfwOnly
matchNsfw OnlyNsfw i = #anyNsfw i matchNsfw OnlyNsfw i = anyNsfw i
matchNsfw AllN _ = True matchNsfw AllN _ = True
instance FromYAML NsfwFilter where instance FromYAML NsfwFilter where
@ -452,9 +465,9 @@ readArtistFilter "all" = pure AllA
readArtistFilter _ = empty readArtistFilter _ = empty
matchArtist :: ArtistFilter -> Info -> Bool matchArtist :: ArtistFilter -> Info -> Bool
matchArtist Me = #mine matchArtist Me i = isNothing i.artist
matchArtist NotMe = #notMine matchArtist NotMe i = isJust i.artist
matchArtist AllA = const True matchArtist AllA _ = True
noFilters :: GalleryFilters noFilters :: GalleryFilters
noFilters = noFilters =
@ -465,7 +478,7 @@ matchFilters (GalleryFilters {nsfw, artist, require, exclude}) i =
matchNsfw nsfw i && matchArtist artist i && matchNsfw nsfw i && matchArtist artist i &&
all (\t -> HashSet.member t tags) require && all (\t -> HashSet.member t tags) require &&
all (\t -> not $ HashSet.member t tags) exclude all (\t -> not $ HashSet.member t tags) exclude
where tags = HashSet.fromList $ #tags i where tags = HashSet.fromList i.tags
instance FromYAML GalleryInfo where instance FromYAML GalleryInfo where

4
make-pages/Main.hs
View File

@ -48,7 +48,7 @@ main = do
main2 :: HasVerbose => ModeOptions -> IO () main2 :: HasVerbose => ModeOptions -> IO ()
main2 (SinglePage {root, file, prefix, index, dataDir, nsfw, output}) = do main2 (SinglePage {root, file, prefix, index, dataDir, nsfw, output}) = do
siteName <- #title <$> readYAML @IndexInfo index siteName <- (.title) <$> readYAML @IndexInfo index
info <- readYAML file info <- readYAML file
printV $ "contents" := info printV $ "contents" := info
let dir = takeDirectory $ makeRelative dataDir file let dir = takeDirectory $ makeRelative dataDir file
@ -121,7 +121,7 @@ galleryFromIndex :: FilePath -> FilePath -> IO GalleryInfo
galleryFromIndex file prefix = do galleryFromIndex file prefix = do
IndexInfo {galleries} <- readYAML file IndexInfo {galleries} <- readYAML file
maybe (fail $ "no gallery with prefix " ++ prefix) pure $ maybe (fail $ "no gallery with prefix " ++ prefix) pure $
List.find (\g -> #prefix g == prefix) galleries List.find (\g -> g.prefix == prefix) galleries
decode1Must :: YAML.FromYAML a => FilePath -> ByteString -> IO a decode1Must :: YAML.FromYAML a => FilePath -> ByteString -> IO a
decode1Must file txt = decode1Must file txt =

13
make-pages/RSS.hs
View File

@ -3,7 +3,6 @@ module RSS (make, make') where
import Date import Date
import Info import Info
import BuilderQQ import BuilderQQ
import Records ()
import Data.List (sortBy) import Data.List (sortBy)
import Data.Maybe (isJust) import Data.Maybe (isJust)
@ -38,10 +37,10 @@ make' root ginfo@(GalleryInfo {title, desc, prefix}) output infos = [b|@0
|] |]
where where
link = [b|$root/$prefix|] link = [b|$root/$prefix|]
nsfw = #nsfw ginfo nsfw = ginfo.nsfw
items = map (uncurry $ makeItem root prefix nsfw) $ items = map (uncurry $ makeItem root prefix nsfw) $
sortBy (flip (compareFor nsfw `on` #second)) $ sortBy (flip (compareFor nsfw `on` snd)) $
filter (not . #unlisted . snd) infos filter (not . (.unlisted) . snd) infos
selflink = case output of selflink = case output of
Nothing -> "" Nothing -> ""
Just o -> [b|<atom:link href="$link/$o" rel="self" />|] Just o -> [b|<atom:link href="$link/$o" rel="self" />|]
@ -57,7 +56,7 @@ makeItem root prefix nsfw path i@(Info {title, artist}) = [b|@4
</item> </item>
|] |]
where where
up = if #updated i nsfw then [b| (updated)|] else "" up = if hasUpdatesFor nsfw i then [b| (updated)|] else ""
dir = takeDirectory path dir = takeDirectory path
link = [b|$root/$prefix/$dir|] link = [b|$root/$prefix/$dir|]
artist' = ifJust artist \case artist' = ifJust artist \case
@ -65,7 +64,7 @@ makeItem root prefix nsfw path i@(Info {title, artist}) = [b|@4
Artist {name, url = Just url} -> [b|<p>by <a href=$url>$name</a>|] Artist {name, url = Just url} -> [b|<p>by <a href=$url>$name</a>|]
desc = descFor nsfw i desc = descFor nsfw i
desc' = makeDesc desc desc' = makeDesc desc
descArtist' = if #exists desc || isJust artist then [b|@6 descArtist' = if desc.exists || isJust artist then [b|@6
<description> <description>
<![CDATA[ <![CDATA[
$10.artist' $10.artist'
@ -74,7 +73,7 @@ makeItem root prefix nsfw path i@(Info {title, artist}) = [b|@4
</description> </description>
|] |]
else "" else ""
date = formatRSS $ #latestDate i nsfw date = formatRSS $ latestDateFor nsfw i
makeDesc :: Desc -> Builder makeDesc :: Desc -> Builder
makeDesc NoDesc = "" makeDesc NoDesc = ""

21
make-pages/Records.hs
View File

@ -1,21 +0,0 @@
{-# OPTIONS_GHC -Wno-orphans #-}
module Records (HasField (..)) where
import GHC.Records
import GHC.OverloadedLabels
instance HasField x r a => IsLabel x (r -> a) where
fromLabel = getField @x
instance HasField "first" (a, b) a where getField (x, _) = x
instance HasField "second" (a, b) b where getField (_, y) = y
instance HasField "first" (a, b, c) a where getField (x, _, _) = x
instance HasField "second" (a, b, c) b where getField (_, y, _) = y
instance HasField "third" (a, b, c) c where getField (_, _, z) = z
instance HasField "first" (a, b, c, d) a where getField (x, _, _, _) = x
instance HasField "second" (a, b, c, d) b where getField (_, y, _, _) = y
instance HasField "third" (a, b, c, d) c where getField (_, _, z, _) = z
instance HasField "fourth" (a, b, c, d) d where getField (_, _, _, w) = w

29
make-pages/SinglePage.hs
View File

@ -4,7 +4,6 @@ module SinglePage (make) where
import Date import Date
import Info import Info
import BuilderQQ import BuilderQQ
import Records ()
import qualified NsfwWarning import qualified NsfwWarning
import Control.Exception import Control.Exception
@ -17,6 +16,7 @@ import System.FilePath (joinPath, splitPath)
import qualified Data.HashSet as Set import qualified Data.HashSet as Set
import Data.Traversable import Data.Traversable
import Data.Semigroup import Data.Semigroup
import Data.List.NonEmpty (toList)
-- | e.g. only nsfw images are present for a non-nsfw page -- | e.g. only nsfw images are present for a non-nsfw page
@ -51,7 +51,7 @@ make' root siteName prefix nsfw _dataDir dir
let buttonBar = makeButtonBar title $ addIds images let buttonBar = makeButtonBar title $ addIds images
let image0 :| otherImages = #all images let image0 :| otherImages = allImages images
let Image {path = path0, download = download0'} = image0 let Image {path = path0, download = download0'} = image0
let download0 = fromMaybe (bigFile path0) download0' let download0 = fromMaybe (bigFile path0) download0'
@ -79,9 +79,9 @@ make' root siteName prefix nsfw _dataDir dir
if you can let me know i'd appreciate it if you can let me know i'd appreciate it
|] |]
let warning' let warning'
| Just w <- #warning image0 = makeWarning w | Just w <- image0.warning = makeWarning w
| #nsfw image0 = makeWarning defWarning | image0.nsfw = makeWarning defWarning
| otherwise = mempty | otherwise = mempty
let warningT = makeWarning [b|.|] let warningT = makeWarning [b|.|]
let bgStyle = case bg of let bgStyle = case bg of
@ -103,7 +103,7 @@ make' root siteName prefix nsfw _dataDir dir
let desc = case artist of let desc = case artist of
Just (Artist {name}) -> [b|by $name|] Just (Artist {name}) -> [b|by $name|]
Nothing -> "by niss" Nothing -> "by niss"
let thumb = getThumb "" info let thumbnail = getThumb "" info
let updateDate = ifJust (last' updates) \(d, _) -> let updateDate = ifJust (last' updates) \(d, _) ->
let updated = formatLong d in let updated = formatLong d in
@ -114,12 +114,12 @@ make' root siteName prefix nsfw _dataDir dir
let nsfwDialog = NsfwWarning.dialog nsfw' let nsfwDialog = NsfwWarning.dialog nsfw'
let imageMeta = let imageMeta =
if #sfw image0 && isNothing (#warning image0) then [b|@0 if image0.sfw && isNothing image0.warning then [b|@0
<meta property=og:image content="$url/$path0'"> <meta property=og:image content="$url/$path0'">
<meta name=twitter:card content=summary_large_image> <meta name=twitter:card content=summary_large_image>
<meta name=twitter:image content="$url/$path0'"> <meta name=twitter:image content="$url/$path0'">
|] else [b|@0 |] else [b|@0
<meta property=og:image content="$url/$thumb"> <meta property=og:image content="$url/$thumbnail">
<meta name=twitter:card content=summary> <meta name=twitter:card content=summary>
|] |]
@ -249,7 +249,7 @@ addIds = snd . mapAccumL makeId Set.empty where
makeId used img = (Set.insert newId used, (img, newId)) where makeId used img = (Set.insert newId used, (img, newId)) where
newId = headI $ filterI (\i -> not $ i `Set.member` used) ids newId = headI $ filterI (\i -> not $ i `Set.member` used) ids
ids = fmap (\i -> toStrictText [b|$label$i|]) suffixes ids = fmap (\i -> toStrictText [b|$label$i|]) suffixes
label = escId $ #label img label = escId $ img.label
pattern One :: a -> NonEmpty a pattern One :: a -> NonEmpty a
@ -287,7 +287,7 @@ makeButtonBar title images =
</ul> |] </ul> |]
where elems = fmap (uncurry altButton) imgs where elems = fmap (uncurry altButton) imgs
skipAll = skipAll =
if any (isJust . #warning . fst) images then if any (isJust . (.warning) . fst) images then
[b|@0 [b|@0
<div class=buttonbar id=skipAllDiv> <div class=buttonbar id=skipAllDiv>
<input type=checkbox name=skipAll id=skipAll> <input type=checkbox name=skipAll id=skipAll>
@ -351,7 +351,7 @@ extLink (Link {title, url}) = [b|@8
</a> </a>
|] |]
makeUpdates :: [(Date, [Update])] -> Builder makeUpdates :: [(Date, NonEmpty Update)] -> Builder
makeUpdates ups = makeUpdates ups =
if all (null . snd) ups then "" else [b|@4 if all (null . snd) ups then "" else [b|@4
<section id=updates class=info-section> <section id=updates class=info-section>
@ -361,13 +361,12 @@ makeUpdates ups =
</dl> </dl>
</section> </section>
|] |]
where updateList = map (uncurry makeUpdate) ups where updateList = fmap (uncurry makeUpdate) ups
makeUpdate :: Date -> [Update] -> Builder makeUpdate :: Date -> NonEmpty Update -> Builder
makeUpdate _ [] = ""
makeUpdate date ups = [b|@8 makeUpdate date ups = [b|@8
<dt>$date' <dt>$date'
<dd>$desc <dd>$desc
|] where |] where
date' = formatSlash date date' = formatSlash date
desc = mconcat $ map fromText $ intersperse "; " $ map #desc ups desc = mconcat $ map fromText $ intersperse "; " $ toList $ fmap (.desc) ups

3
make-pages/make-pages.cabal
View File

@ -15,7 +15,6 @@ executable make-pages
main-is: Main.hs main-is: Main.hs
other-modules: other-modules:
BuilderQQ, BuilderQQ,
Records,
Date, Date,
Info, Info,
Depend, Depend,
@ -32,9 +31,9 @@ executable make-pages
DeriveAnyClass, DeriveAnyClass,
DerivingVia, DerivingVia,
DuplicateRecordFields, DuplicateRecordFields,
OverloadedLabels,
OverloadedLists, OverloadedLists,
OverloadedStrings, OverloadedStrings,
OverloadedRecordDot,
QuasiQuotes, QuasiQuotes,
TypeSynonymInstances, TypeSynonymInstances,
ViewPatterns ViewPatterns