replace OverloadedLabels with OverloadedRecordDot
This commit is contained in:
parent
cd5801dd7d
commit
28520eb443
8 changed files with 126 additions and 138 deletions
|
|
@ -29,12 +29,12 @@ dependSingle' yamlDir indexFile info prefix build nsfw =
|
|||
[b|$page: $deps $indexFile $$(MAKEPAGES)|]
|
||||
where
|
||||
images =
|
||||
maybe [] (toList . #all) $
|
||||
if nsfw then Just $ #images info else #sfwImages info
|
||||
maybe [] (toList . allImages) $
|
||||
if nsfw then Just $ info.images else sfwImages info
|
||||
|
||||
paths = map #path images
|
||||
dls = mapMaybe #download images
|
||||
extras = #extras info
|
||||
paths = map (.path) images
|
||||
dls = mapMaybe (.download) images
|
||||
extras = info.extras
|
||||
|
||||
dir = build </> prefix </> yamlDir
|
||||
page = dir </> "index.html"
|
||||
|
|
@ -71,9 +71,9 @@ dependGallery' (GalleryInfo {prefix, filters})
|
|||
$incs
|
||||
|]
|
||||
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
|
||||
|
||||
page d = build </> prefix </> takeDirectory d </> "index.html"
|
||||
|
|
@ -120,4 +120,4 @@ filtersToFlags (GalleryFilters {nsfw}) =
|
|||
case nsfw of NoNsfw -> ""; _ -> "-n"
|
||||
|
||||
thumbnail :: Info -> FilePath
|
||||
thumbnail = fromMaybe (error "no thumbnail or sfw images") . #thumb
|
||||
thumbnail = fromMaybe (error "no thumbnail or sfw images") . thumb
|
||||
|
|
|
|||
|
|
@ -91,21 +91,21 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
|
|||
|
||||
infosByYear :: [(Int, [(FilePath, Info)])]
|
||||
infosByYear = infos &
|
||||
filter (not . #unlisted . snd) &
|
||||
filter (not . (.unlisted) . snd) &
|
||||
sortOn (Down . compareKeyFor nsfw . snd) &
|
||||
groupOnKey (\(_, i) -> #latestYear i nsfw)
|
||||
groupOnKey (\(_, i) -> latestYearFor nsfw i)
|
||||
|
||||
undir = joinPath (replicate (length (splitPath prefix)) "..")
|
||||
|
||||
allTags = infos
|
||||
& concatMap (map (,1) . tagsFor nsfw . #second)
|
||||
& concatMap (map (,1) . tagsFor nsfw . snd)
|
||||
& HashMap.fromListWith (+) & HashMap.toList
|
||||
& sort
|
||||
|
||||
requireFilters = map (uncurry $ makeFilter "require" mempty) allTags
|
||||
excludeFilters = map (uncurry $ makeFilter "exclude" hidden) allTags
|
||||
|
||||
nsfw = #nsfw filters /= NoNsfw
|
||||
nsfw = filters.nsfw /= NoNsfw
|
||||
|
||||
url = [b|$root/$prefix|]
|
||||
imagepath0
|
||||
|
|
@ -153,22 +153,21 @@ makeItem nsfw file info@(Info {bg}) = [b|@0
|
|||
<li class="item post$nsfw'" data-year=$year' data-updated="$updated'"
|
||||
data-tags="$tags'">
|
||||
<a href="$dir">
|
||||
<img src="$thumb" loading=lazy$bgStyle
|
||||
<img src="$thumbnail" loading=lazy$bgStyle
|
||||
width=200 height=200
|
||||
title="$tooltip">
|
||||
</a>
|
||||
|]
|
||||
where
|
||||
title = fromMaybe (#title info) $ #galleryTitle info
|
||||
dir = takeDirectory file
|
||||
thumb = getThumb dir info
|
||||
nsfw' = if nsfw && #anyNsfw info then [b| nsfw|] else ""
|
||||
tags' = fold $ intersperse ";" $ map fromText $ tagsFor nsfw info
|
||||
date = #latestDate info nsfw
|
||||
date' = formatTooltip date
|
||||
year' = #year date
|
||||
updated' = if #updated info nsfw then [b|true|] else [b|false|]
|
||||
bgStyle = case bg of Other col -> [b| style="background: $col"|]; _ -> ""
|
||||
tooltip =
|
||||
let upd = if #updated info nsfw then "updated " else "" :: Builder in
|
||||
[b|$title ($upd$date')|]
|
||||
title = fromMaybe info.title $ info.galleryTitle
|
||||
dir = takeDirectory file
|
||||
thumbnail = getThumb dir info
|
||||
nsfw' = if nsfw && anyNsfw info then [b| nsfw|] else ""
|
||||
tags' = fold $ intersperse ";" $ map fromText $ tagsFor nsfw info
|
||||
date = latestDateFor nsfw info
|
||||
date' = formatTooltip date
|
||||
year' = date.year
|
||||
updated' = if hasUpdatesFor nsfw info then [b|true|] else [b|false|]
|
||||
bgStyle = case bg of Other col -> [b| style="background: $col"|]; _ -> ""
|
||||
tooltip = [b|$title ($upd$date')|]
|
||||
where upd = if hasUpdatesFor nsfw info then "updated " else "" :: Builder
|
||||
|
|
|
|||
|
|
@ -3,20 +3,31 @@
|
|||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
module 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,
|
||||
|
||||
Artist (..), Images' (..), Images, Image (..), Desc (..), DescField (..),
|
||||
|
||||
Link (..), Update (..), Bg (..),
|
||||
|
||||
GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..),
|
||||
IndexInfo (..),
|
||||
readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters,
|
||||
|
||||
IndexInfo (..),
|
||||
|
||||
NoThumb (..), getThumb, thumbFile, pageFile, bigFile,
|
||||
-- ** Reexports
|
||||
Date (..), Day (..), Text, NonEmpty (..))
|
||||
where
|
||||
|
||||
import Date
|
||||
import Records
|
||||
import GHC.Records
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
|
|
@ -38,7 +49,6 @@ import qualified Data.Text as Text
|
|||
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
|
||||
import qualified Data.YAML as YAML
|
||||
import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension)
|
||||
import Data.Bifunctor (second)
|
||||
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
|
||||
-- put them in the right order in the gallery
|
||||
sortEx :: !Text,
|
||||
updates :: ![(Date, [Update])],
|
||||
updates :: ![(Date, NonEmpty Update)],
|
||||
-- | if false, don't show updated emblem even if @updates@ is non-empty
|
||||
showUpdated :: !Bool,
|
||||
-- | hide from gallery view
|
||||
|
|
@ -123,13 +133,13 @@ data Update =
|
|||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance HasField "sfw" Image Bool where getField = not . #nsfw
|
||||
instance HasField "sfw" Link Bool where getField = not . #nsfw
|
||||
instance HasField "sfw" Update Bool where getField = not . #nsfw
|
||||
instance HasField "sfw" Image Bool where getField i = not i.nsfw
|
||||
instance HasField "sfw" Link Bool where getField i = not i.nsfw
|
||||
instance HasField "sfw" Update Bool where getField i = not i.nsfw
|
||||
|
||||
instance HasField "all" (Images' a) (NonEmpty a) where
|
||||
getField (Uncat is) = is
|
||||
getField (Cat cats) = sconcat $ fmap snd cats
|
||||
allImages :: Images' a -> NonEmpty a
|
||||
allImages (Uncat is) = is
|
||||
allImages (Cat cats) = sconcat $ fmap snd cats
|
||||
|
||||
filterNE :: (a -> Bool) -> NonEmpty a -> Maybe (NonEmpty a)
|
||||
filterNE p = nonEmpty . filter p . toList
|
||||
|
|
@ -142,45 +152,51 @@ filterImages p (Uncat is) = Uncat <$> filterNE p is
|
|||
filterImages p (Cat cats) =
|
||||
fmap Cat $ catMaybesNE $ fmap (traverse $ filterNE p) cats
|
||||
|
||||
instance HasField "sfwImages" Info (Maybe Images) where
|
||||
getField = filterImages #sfw . #images
|
||||
instance HasField "nsfwImages" Info (Maybe Images) where
|
||||
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
|
||||
sfwImages, nsfwImages :: Info -> Maybe Images
|
||||
sfwImages i = filterImages (.sfw) i.images
|
||||
nsfwImages i = filterImages (.nsfw) i.images
|
||||
|
||||
instance HasField "sfwLinks" Info [Link] where
|
||||
getField = filter #sfw . #links
|
||||
instance HasField "nsfwLinks" Info [Link] where
|
||||
getField = filter #nsfw . #links
|
||||
anySfw, anyNsfw, allSfw, allNsfw :: Info -> Bool
|
||||
anySfw = isJust . sfwImages
|
||||
anyNsfw = isJust . nsfwImages
|
||||
allSfw = not . anyNsfw
|
||||
allNsfw = not . anySfw
|
||||
|
||||
instance HasField "sfwUpdates" Info [(Date, [Update])] where
|
||||
getField = filter (not . null) . map (second (filter #sfw)) . #updates
|
||||
instance HasField "nsfwUpdates" Info [(Date, [Update])] where
|
||||
getField = filter (not . null) . map (second (filter #nsfw)) . #updates
|
||||
sfwLinks, nsfwLinks :: Info -> [Link]
|
||||
sfwLinks i = filter (.sfw) i.links
|
||||
nsfwLinks i = filter (.nsfw) i.links
|
||||
|
||||
instance HasField "thumb" Info (Maybe FilePath) where
|
||||
getField (Info {thumb', images}) =
|
||||
thumb' <|> #path <$> find #sfw (#all images)
|
||||
updatesWith :: (Update -> Bool) -> Info -> [(Date, NonEmpty Update)]
|
||||
updatesWith p i = mapMaybe (traverse $ filterNE p) i.updates
|
||||
|
||||
instance HasField "mine" Info Bool where getField = isNothing . #artist
|
||||
instance HasField "notMine" Info Bool where getField = isJust . #artist
|
||||
updatesFor :: Bool -> Info -> [(Date, NonEmpty Update)]
|
||||
updatesFor nsfw = updatesWith \u -> nsfw || u.sfw
|
||||
|
||||
instance HasField "latestDate" Info (Bool -> Date) where
|
||||
getField info@(Info {date=date₀}) nsfw =
|
||||
maximum $ date₀ : mapMaybe relDate (updatesFor nsfw info)
|
||||
where
|
||||
relDate (date, us) = date <$ guard (not $ null us || any #ignoreSort us)
|
||||
sfwUpdates, nsfwUpdates :: Info -> [(Date, NonEmpty Update)]
|
||||
sfwUpdates = updatesWith (.sfw)
|
||||
nsfwUpdates = updatesWith (.nsfw)
|
||||
|
||||
instance HasField "latestYear" Info (Bool -> Int) where
|
||||
getField info nsfw = #year $ #latestDate info nsfw
|
||||
lastUpdateFor :: Bool -> Info -> Maybe Date
|
||||
lastUpdateFor nsfw info = case updatesFor nsfw info of
|
||||
[] -> Nothing
|
||||
us -> Just $ fst $ last us
|
||||
|
||||
|
||||
instance HasField "updated" Info (Bool -> Bool) where
|
||||
getField (Info {updates, showUpdated}) nsfw = showUpdated && updated where
|
||||
updated = if nsfw then not $ null updates else any (any #sfw . snd) updates
|
||||
thumb :: Info -> Maybe FilePath
|
||||
thumb (Info {thumb', images}) =
|
||||
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 = "about"
|
||||
|
|
@ -202,8 +218,8 @@ merge fs1 fs2 = go fs1 [] fs2 where
|
|||
Nothing -> go first (x:unused) xs
|
||||
insert [] _ = Nothing
|
||||
insert (x:xs) y =
|
||||
if #name x == #name y then
|
||||
Just $ x {text = #text x <> #text y} : xs
|
||||
if x.name == y.name then
|
||||
Just $ x {text = x.text <> y.text} : xs
|
||||
else
|
||||
(x :) <$> insert xs y
|
||||
|
||||
|
|
@ -218,26 +234,19 @@ descFor :: Bool -> Info -> Desc
|
|||
descFor nsfw (Info {desc, nsfwDesc}) = if nsfw then desc <> nsfwDesc else desc
|
||||
|
||||
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 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 nsfw = if nsfw then #links else #sfwLinks
|
||||
|
||||
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
|
||||
linksFor nsfw i = if nsfw then i.links else sfwLinks i
|
||||
|
||||
data CompareKey = MkCompareKey !Date !Text !Text
|
||||
deriving (Eq, Ord)
|
||||
|
||||
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 nsfw = comparing $ compareKeyFor nsfw
|
||||
|
|
@ -252,7 +261,7 @@ instance Show NoThumb where show (NoThumb dir) = "no thumbnail for " ++ dir
|
|||
|
||||
getThumb :: FilePath -> Info -> FilePath
|
||||
getThumb dir =
|
||||
maybe (throw $ NoThumb dir) (\t -> dir </> thumbFile t) . #thumb
|
||||
maybe (throw $ NoThumb dir) (\t -> dir </> thumbFile t) . thumb
|
||||
|
||||
thumbFile :: FilePath -> FilePath
|
||||
thumbFile = addSuffix "_small"
|
||||
|
|
@ -385,9 +394,11 @@ instance FromYAML Link where
|
|||
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 =
|
||||
maybe (pure []) $ YAML.withMap "updates" $ traverse bodies . Map.toList
|
||||
maybe (pure []) $ YAML.withMap "updates" $
|
||||
nonEmptys <=< traverse bodies . Map.toList
|
||||
where
|
||||
bodies (date', rest) = (,) <$> parseYAML date' <*> body rest
|
||||
body b =
|
||||
|
|
@ -402,6 +413,8 @@ updateList =
|
|||
nsfw <- m .:? "nsfw" .!= False
|
||||
ignoreSort <- m .:? "ignore-sort" .!= False
|
||||
pure $ Update {desc, nsfw, ignoreSort}
|
||||
nonEmptys = traverse $ traverse $
|
||||
maybe (fail "expected non-empty list") pure . nonEmpty
|
||||
|
||||
|
||||
data GalleryInfo =
|
||||
|
|
@ -415,7 +428,7 @@ data GalleryInfo =
|
|||
deriving (Eq, Show)
|
||||
|
||||
instance HasField "nsfw" GalleryInfo Bool where
|
||||
getField g = #nsfw (#filters g) /= NoNsfw
|
||||
getField g = g.filters.nsfw /= NoNsfw
|
||||
|
||||
data GalleryFilters =
|
||||
GalleryFilters {
|
||||
|
|
@ -434,8 +447,8 @@ readNsfwFilter "all" = pure AllN
|
|||
readNsfwFilter _ = empty
|
||||
|
||||
matchNsfw :: NsfwFilter -> Info -> Bool
|
||||
matchNsfw NoNsfw i = #anySfw i && not (#nsfwOnly i)
|
||||
matchNsfw OnlyNsfw i = #anyNsfw i
|
||||
matchNsfw NoNsfw i = anySfw i && not i.nsfwOnly
|
||||
matchNsfw OnlyNsfw i = anyNsfw i
|
||||
matchNsfw AllN _ = True
|
||||
|
||||
instance FromYAML NsfwFilter where
|
||||
|
|
@ -452,9 +465,9 @@ readArtistFilter "all" = pure AllA
|
|||
readArtistFilter _ = empty
|
||||
|
||||
matchArtist :: ArtistFilter -> Info -> Bool
|
||||
matchArtist Me = #mine
|
||||
matchArtist NotMe = #notMine
|
||||
matchArtist AllA = const True
|
||||
matchArtist Me i = isNothing i.artist
|
||||
matchArtist NotMe i = isJust i.artist
|
||||
matchArtist AllA _ = True
|
||||
|
||||
noFilters :: GalleryFilters
|
||||
noFilters =
|
||||
|
|
@ -465,7 +478,7 @@ matchFilters (GalleryFilters {nsfw, artist, require, exclude}) i =
|
|||
matchNsfw nsfw i && matchArtist artist i &&
|
||||
all (\t -> HashSet.member t tags) require &&
|
||||
all (\t -> not $ HashSet.member t tags) exclude
|
||||
where tags = HashSet.fromList $ #tags i
|
||||
where tags = HashSet.fromList i.tags
|
||||
|
||||
|
||||
instance FromYAML GalleryInfo where
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ main = do
|
|||
|
||||
main2 :: HasVerbose => ModeOptions -> IO ()
|
||||
main2 (SinglePage {root, file, prefix, index, dataDir, nsfw, output}) = do
|
||||
siteName <- #title <$> readYAML @IndexInfo index
|
||||
siteName <- (.title) <$> readYAML @IndexInfo index
|
||||
info <- readYAML file
|
||||
printV $ "contents" := info
|
||||
let dir = takeDirectory $ makeRelative dataDir file
|
||||
|
|
@ -121,7 +121,7 @@ galleryFromIndex :: FilePath -> FilePath -> IO GalleryInfo
|
|||
galleryFromIndex file prefix = do
|
||||
IndexInfo {galleries} <- readYAML file
|
||||
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 file txt =
|
||||
|
|
|
|||
|
|
@ -3,7 +3,6 @@ module RSS (make, make') where
|
|||
import Date
|
||||
import Info
|
||||
import BuilderQQ
|
||||
import Records ()
|
||||
|
||||
import Data.List (sortBy)
|
||||
import Data.Maybe (isJust)
|
||||
|
|
@ -38,10 +37,10 @@ make' root ginfo@(GalleryInfo {title, desc, prefix}) output infos = [b|@0
|
|||
|]
|
||||
where
|
||||
link = [b|$root/$prefix|]
|
||||
nsfw = #nsfw ginfo
|
||||
nsfw = ginfo.nsfw
|
||||
items = map (uncurry $ makeItem root prefix nsfw) $
|
||||
sortBy (flip (compareFor nsfw `on` #second)) $
|
||||
filter (not . #unlisted . snd) infos
|
||||
sortBy (flip (compareFor nsfw `on` snd)) $
|
||||
filter (not . (.unlisted) . snd) infos
|
||||
selflink = case output of
|
||||
Nothing -> ""
|
||||
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>
|
||||
|]
|
||||
where
|
||||
up = if #updated i nsfw then [b| (updated)|] else ""
|
||||
up = if hasUpdatesFor nsfw i then [b| (updated)|] else ""
|
||||
dir = takeDirectory path
|
||||
link = [b|$root/$prefix/$dir|]
|
||||
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>|]
|
||||
desc = descFor nsfw i
|
||||
desc' = makeDesc desc
|
||||
descArtist' = if #exists desc || isJust artist then [b|@6
|
||||
descArtist' = if desc.exists || isJust artist then [b|@6
|
||||
<description>
|
||||
<![CDATA[
|
||||
$10.artist'
|
||||
|
|
@ -74,7 +73,7 @@ makeItem root prefix nsfw path i@(Info {title, artist}) = [b|@4
|
|||
</description>
|
||||
|]
|
||||
else ""
|
||||
date = formatRSS $ #latestDate i nsfw
|
||||
date = formatRSS $ latestDateFor nsfw i
|
||||
|
||||
makeDesc :: Desc -> Builder
|
||||
makeDesc NoDesc = ""
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -4,7 +4,6 @@ module SinglePage (make) where
|
|||
import Date
|
||||
import Info
|
||||
import BuilderQQ
|
||||
import Records ()
|
||||
import qualified NsfwWarning
|
||||
|
||||
import Control.Exception
|
||||
|
|
@ -17,6 +16,7 @@ import System.FilePath (joinPath, splitPath)
|
|||
import qualified Data.HashSet as Set
|
||||
import Data.Traversable
|
||||
import Data.Semigroup
|
||||
import Data.List.NonEmpty (toList)
|
||||
|
||||
|
||||
-- | 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 image0 :| otherImages = #all images
|
||||
let image0 :| otherImages = allImages images
|
||||
let Image {path = path0, download = download0'} = image0
|
||||
|
||||
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
|
||||
|]
|
||||
let warning'
|
||||
| Just w <- #warning image0 = makeWarning w
|
||||
| #nsfw image0 = makeWarning defWarning
|
||||
| otherwise = mempty
|
||||
| Just w <- image0.warning = makeWarning w
|
||||
| image0.nsfw = makeWarning defWarning
|
||||
| otherwise = mempty
|
||||
let warningT = makeWarning [b|.|]
|
||||
|
||||
let bgStyle = case bg of
|
||||
|
|
@ -103,7 +103,7 @@ make' root siteName prefix nsfw _dataDir dir
|
|||
let desc = case artist of
|
||||
Just (Artist {name}) -> [b|by $name|]
|
||||
Nothing -> "by niss"
|
||||
let thumb = getThumb "" info
|
||||
let thumbnail = getThumb "" info
|
||||
|
||||
let updateDate = ifJust (last' updates) \(d, _) ->
|
||||
let updated = formatLong d in
|
||||
|
|
@ -114,12 +114,12 @@ make' root siteName prefix nsfw _dataDir dir
|
|||
let nsfwDialog = NsfwWarning.dialog nsfw'
|
||||
|
||||
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 name=twitter:card content=summary_large_image>
|
||||
<meta name=twitter:image content="$url/$path0'">
|
||||
|] else [b|@0
|
||||
<meta property=og:image content="$url/$thumb">
|
||||
<meta property=og:image content="$url/$thumbnail">
|
||||
<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
|
||||
newId = headI $ filterI (\i -> not $ i `Set.member` used) ids
|
||||
ids = fmap (\i -> toStrictText [b|$label$i|]) suffixes
|
||||
label = escId $ #label img
|
||||
label = escId $ img.label
|
||||
|
||||
|
||||
pattern One :: a -> NonEmpty a
|
||||
|
|
@ -287,7 +287,7 @@ makeButtonBar title images =
|
|||
</ul> |]
|
||||
where elems = fmap (uncurry altButton) imgs
|
||||
skipAll =
|
||||
if any (isJust . #warning . fst) images then
|
||||
if any (isJust . (.warning) . fst) images then
|
||||
[b|@0
|
||||
<div class=buttonbar id=skipAllDiv>
|
||||
<input type=checkbox name=skipAll id=skipAll>
|
||||
|
|
@ -351,7 +351,7 @@ extLink (Link {title, url}) = [b|@8
|
|||
</a>
|
||||
|]
|
||||
|
||||
makeUpdates :: [(Date, [Update])] -> Builder
|
||||
makeUpdates :: [(Date, NonEmpty Update)] -> Builder
|
||||
makeUpdates ups =
|
||||
if all (null . snd) ups then "" else [b|@4
|
||||
<section id=updates class=info-section>
|
||||
|
|
@ -361,13 +361,12 @@ makeUpdates ups =
|
|||
</dl>
|
||||
</section>
|
||||
|]
|
||||
where updateList = map (uncurry makeUpdate) ups
|
||||
where updateList = fmap (uncurry makeUpdate) ups
|
||||
|
||||
makeUpdate :: Date -> [Update] -> Builder
|
||||
makeUpdate _ [] = ""
|
||||
makeUpdate :: Date -> NonEmpty Update -> Builder
|
||||
makeUpdate date ups = [b|@8
|
||||
<dt>$date'
|
||||
<dd>$desc
|
||||
|] where
|
||||
date' = formatSlash date
|
||||
desc = mconcat $ map fromText $ intersperse "; " $ map #desc ups
|
||||
desc = mconcat $ map fromText $ intersperse "; " $ toList $ fmap (.desc) ups
|
||||
|
|
|
|||
|
|
@ -15,7 +15,6 @@ executable make-pages
|
|||
main-is: Main.hs
|
||||
other-modules:
|
||||
BuilderQQ,
|
||||
Records,
|
||||
Date,
|
||||
Info,
|
||||
Depend,
|
||||
|
|
@ -32,9 +31,9 @@ executable make-pages
|
|||
DeriveAnyClass,
|
||||
DerivingVia,
|
||||
DuplicateRecordFields,
|
||||
OverloadedLabels,
|
||||
OverloadedLists,
|
||||
OverloadedStrings,
|
||||
OverloadedRecordDot,
|
||||
QuasiQuotes,
|
||||
TypeSynonymInstances,
|
||||
ViewPatterns
|
||||
|
|
|
|||
Loading…
Reference in a new issue