From 2ccfb72b224c303b093469e97107a05b249f6e6b Mon Sep 17 00:00:00 2001 From: Rhiannon Morris Date: Mon, 23 Aug 2021 16:30:11 +0200 Subject: [PATCH 1/4] add support for categorised alts --- make-pages/Depend.hs | 2 +- make-pages/Info.hs | 49 ++++++++++++++++++++++++++++--------- make-pages/SinglePage.hs | 46 ++++++++++++++++++++-------------- make-pages/make-pages.cabal | 2 ++ 4 files changed, 68 insertions(+), 31 deletions(-) diff --git a/make-pages/Depend.hs b/make-pages/Depend.hs index df3db9c..269f757 100644 --- a/make-pages/Depend.hs +++ b/make-pages/Depend.hs @@ -25,7 +25,7 @@ dependSingle' :: FilePath -> Info -> FilePath -> FilePath -> Bool -> Builder dependSingle' yamlDir info prefix build nsfw = [b|$page: $deps $$(MAKEPAGES)|] where - images = if nsfw then #images info else #sfwImages info + images = #all if nsfw then #images info else #sfwImages info paths = map #path images dls = mapMaybe #download images diff --git a/make-pages/Info.hs b/make-pages/Info.hs index 9285788..b942a56 100644 --- a/make-pages/Info.hs +++ b/make-pages/Info.hs @@ -2,7 +2,8 @@ module Info (Info (..), tagsFor, descFor, imagesFor, linksFor, updatesFor, compareFor, sortFor, - Artist (..), Image (..), Desc (..), DescField (..), Link (..), Update (..), + Artist (..), Images' (..), Images, Image (..), Desc (..), DescField (..), + Link (..), Update (..), GalleryInfo (..), GalleryFilters (..), ArtistFilter (..), NsfwFilter (..), IndexInfo (..), readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters, @@ -31,6 +32,7 @@ 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) data Info = @@ -51,7 +53,7 @@ data Info = desc :: !Desc, nsfwDesc :: !Desc, bg :: !(Maybe Text), - images :: ![Image], + images :: !Images, thumb' :: !(Maybe FilePath), links :: ![Link], extras :: ![FilePath] @@ -84,6 +86,14 @@ data Image = } deriving (Eq, Show) +data Images' a = + Uncat [a] -- ^ uncategorised + | Cat [(Text, [a])] -- ^ categorised + deriving (Eq, Show, Functor, Foldable, Traversable) + +type Images = Images' Image + + data Link = Link { title :: !Text, @@ -105,12 +115,21 @@ 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 "sfwImages" Info [Image] where - getField = filter #sfw . #images -instance HasField "nsfwImages" Info [Image] where - getField = filter #nsfw . #images -instance HasField "allNsfw" Info Bool where getField = null . #sfwImages -instance HasField "allSfw" Info Bool where getField = null . #nsfwImages +instance HasField "all" (Images' a) [a] where + getField (Uncat is) = is + getField (Cat cats) = foldMap snd cats + +filterImages :: (a -> Bool) -> Images' a -> Images' a +filterImages p (Uncat is) = Uncat $ filter p is +filterImages p (Cat cats) = + Cat $ filter (not . null . snd) $ map (second $ filter p) cats + +instance HasField "sfwImages" Info Images where + getField = filterImages #sfw . #images +instance HasField "nsfwImages" Info Images where + getField = filterImages #nsfw . #images +instance HasField "allNsfw" Info Bool where getField = null . #all . #sfwImages +instance HasField "allSfw" Info Bool where getField = null . #all . #nsfwImages instance HasField "anySfw" Info Bool where getField = not . #allNsfw instance HasField "anyNsfw" Info Bool where getField = not . #allSfw @@ -125,7 +144,8 @@ instance HasField "nsfwUpdates" Info [Update] where getField = filter #nsfw . #updates instance HasField "thumb" Info (Maybe FilePath) where - getField (Info {thumb', images}) = thumb' <|> #path <$> find #sfw images + getField (Info {thumb', images}) = + thumb' <|> #path <$> find #sfw (#all images) instance HasField "mine" Info Bool where getField = isNothing . #artist instance HasField "notMine" Info Bool where getField = isJust . #artist @@ -181,7 +201,7 @@ 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 -imagesFor :: Bool -> Info -> [Image] +imagesFor :: Bool -> Info -> Images imagesFor nsfw = if nsfw then #images else #sfwImages linksFor :: Bool -> Info -> [Link] @@ -233,7 +253,7 @@ instance FromYAML Info where <*> m .:? "desc" .!= NoDesc <*> m .:? "nsfw-desc" .!= NoDesc <*> m .:? "bg" - <*> (m .: "images" >>= imageList) + <*> m .: "images" <*> m .:? "thumb" <*> m .:? "links" .!= [] <*> m .:? "extras" .!= [] @@ -261,7 +281,7 @@ instance FromYAML Image where unlabelledImage :: YAML.Node YAML.Pos -> YAML.Parser Image unlabelledImage = unlabelledImage' Nothing -unlabelledImage' :: Maybe Text -> YAML.Node YAML.Pos -> YAML.Parser Image +unlabelledImage' :: Maybe Text -> YAML.Node YAML.Pos -> YAML.Parser Image unlabelledImage' label' y = asStr y <|> asObj y where asStr = YAML.withStr "path" \(Text.unpack -> path) -> @@ -278,6 +298,11 @@ unlabelledImage' label' y = asStr y <|> asObj y pathToLabel = Text.pack . gapToSpace . takeBaseName gapToSpace = map \case '-' -> ' '; '_' -> ' '; c -> c +instance FromYAML Images where + parseYAML y = Uncat <$> imageList y + <|> Cat <$> YAML.withSeq "list of categories" fromPairs y + where fromPairs = traverse $ withPairM \label -> fmap (label,) . imageList + instance FromYAML Link where parseYAML = withPairM \title rest -> asStr title rest <|> asObj title rest diff --git a/make-pages/SinglePage.hs b/make-pages/SinglePage.hs index 9ff5a6d..dd07189 100644 --- a/make-pages/SinglePage.hs +++ b/make-pages/SinglePage.hs @@ -47,8 +47,8 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do let buttonBar = makeButtonBar title images let (image0@(Image {path = path0, download = download0'}), - Size {width = width0, height = height0}) - = head images + Size {width = width0, height = height0}) : otherImages + = #all images let download0 = fromMaybe path0 download0' let path0' = pageFile path0 let tinyCls = if any (tiny . #second) images then [b| class=tiny|] else "" @@ -60,7 +60,7 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do let updatesList = makeUpdates updates let makePrefetch (Image {path}) = [b||] - let prefetches = map (makePrefetch . #first) $ tail images + let prefetches = map (makePrefetch . #first) otherImages let makeWarning w = [b|@0
@@ -195,24 +195,35 @@ makeDesc (LongDesc fs) = [b|@0 |] -makeButtonBar :: Strict.Text -> [(Image, Size)] -> Builder +makeButtonBar :: Strict.Text -> Images' (Image, Size) -> Builder makeButtonBar title images = case images of - [] -> throw $ NoEligibleImages title - [_] -> "" - _ -> [b|@0 - - |] - where alts = map (\(i, (im, sz)) -> altButton i im sz) $ zip [0..] images + $2.elems + |] + where elems = map (uncurry altButton) imgs -altButton :: Int -> Image -> Size -> Builder -altButton i img size = [b|@0 +altButton :: Image -> Size -> Builder +altButton img size = [b|@0 - @@ -222,7 +233,6 @@ altButton i img size = [b|@0 Size {width, height} = size nsfwClass = if nsfw then [b| class=nsfw|] else "" nsfwLabelClass = if nsfw then [b| class=nsfw-label|] else "" - checked = if i == 0 then [b| checked|] else "" idLabel = escId label path' = pageFile path link = fromMaybe path download @@ -297,7 +307,7 @@ imageSize dir img = do Just (width, height) -> pure $ Size {width, height} Nothing -> fail $ "couldn't understand identify output:\n" ++ output -withSizes :: FilePath -> [Image] -> IO [(Image, Size)] +withSizes :: Traversable t => FilePath -> t Image -> IO (t (Image, Size)) withSizes dir = traverse \img -> do size <- imageSize dir $ #path img pure (img, size) diff --git a/make-pages/make-pages.cabal b/make-pages/make-pages.cabal index 9ff3431..d564260 100644 --- a/make-pages/make-pages.cabal +++ b/make-pages/make-pages.cabal @@ -32,6 +32,7 @@ executable make-pages ConstraintKinds, DataKinds, DeriveAnyClass, + DeriveTraversable, DerivingStrategies, DerivingVia, DuplicateRecordFields, @@ -46,6 +47,7 @@ executable make-pages PatternSynonyms, QuasiQuotes, RankNTypes, + ScopedTypeVariables, StandaloneDeriving, TupleSections, TypeSynonymInstances, From 8e5e066699c33a05fed394dbb25b56aac5d413bd Mon Sep 17 00:00:00 2001 From: Rhiannon Morris Date: Mon, 23 Aug 2021 16:35:36 +0200 Subject: [PATCH 2/4] style the categories --- style/shiny/single.css | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/style/shiny/single.css b/style/shiny/single.css index 2646a4d..73584d6 100644 --- a/style/shiny/single.css +++ b/style/shiny/single.css @@ -199,3 +199,18 @@ footer { font-size: 150%; } } + + +#alts { + margin: 1.5em 0; + text-align: center; +} + +.cat :is(h3,ul) { margin: 0; } + +#alts h3 { + font-weight: 600; + display: inline; + padding-right: 0.5em; +} +#alts ul { display: inline flex; } From 004e43f52f0a802c49894c48b2caf7121357e6b3 Mon Sep 17 00:00:00 2001 From: Rhiannon Morris Date: Mon, 23 Aug 2021 16:35:55 +0200 Subject: [PATCH 3/4] ensure ids are unique --- make-pages/BuilderQQ.hs | 2 +- make-pages/SinglePage.hs | 24 ++++++++++++++++-------- 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/make-pages/BuilderQQ.hs b/make-pages/BuilderQQ.hs index 097094c..bde71c7 100644 --- a/make-pages/BuilderQQ.hs +++ b/make-pages/BuilderQQ.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module BuilderQQ (b, - Builder, toLazyText, fromText, fromString, fromChar, + Builder, toStrictText, toLazyText, fromText, fromString, fromChar, textMap, ifJust, escId, escAttr) where diff --git a/make-pages/SinglePage.hs b/make-pages/SinglePage.hs index dd07189..5aee691 100644 --- a/make-pages/SinglePage.hs +++ b/make-pages/SinglePage.hs @@ -14,6 +14,8 @@ import qualified Data.Text.Lazy as Lazy import System.FilePath (joinPath, splitPath, ()) import qualified System.Process as Proc import Text.Read (readMaybe) +import qualified Data.HashSet as Set +import Data.Traversable -- | e.g. only nsfw images are present for a non-nsfw page @@ -45,7 +47,7 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do let formattedDate = formatLong date - let buttonBar = makeButtonBar title images + let buttonBar = makeButtonBar title $ addIds images let (image0@(Image {path = path0, download = download0'}), Size {width = width0, height = height0}) : otherImages = #all images @@ -195,7 +197,14 @@ makeDesc (LongDesc fs) = [b|@0 |] -makeButtonBar :: Strict.Text -> Images' (Image, Size) -> Builder +addIds :: Images' (Image, a) -> Images' (Image, a, Text) +addIds = snd . mapAccumL makeId Set.empty where + makeId used (img, x) = (Set.insert newId used, (img, x, newId)) where + newId = head $ filter (\i -> not $ i `Set.member` used) ids + ids = [toStrictText [b|$label$i|] | i <- "" : map show [0::Int ..]] + label = escId $ #label img + +makeButtonBar :: Strict.Text -> Images' (Image, Size, Text) -> Builder makeButtonBar title images = case images of Uncat [] -> throw $ NoEligibleImages title @@ -218,22 +227,21 @@ makeButtonBar title images =
    $2.elems
|] - where elems = map (uncurry altButton) imgs + where elems = map (\(img,sz,i) -> altButton img sz i) imgs -altButton :: Image -> Size -> Builder -altButton img size = [b|@0 +altButton :: Image -> Size -> Text -> Builder +altButton img size i = [b|@0 - - + |] where Image {label, path, nsfw, warning, download} = img Size {width, height} = size nsfwClass = if nsfw then [b| class=nsfw|] else "" nsfwLabelClass = if nsfw then [b| class=nsfw-label|] else "" - idLabel = escId label path' = pageFile path link = fromMaybe path download warning' = ifJust warning \(escAttr -> w) -> [b| data-warning="$w"|] From 2d27465ffcc950b6f4c8d4b93ea450165519a93a Mon Sep 17 00:00:00 2001 From: Rhiannon Morris Date: Mon, 23 Aug 2021 16:38:51 +0200 Subject: [PATCH 4/4] remove the individual 18+ badges from alts with the badge on the gallery, and the 'are you an adult?' popup, and the cw before showing the image, they're probably unnecessary and they add a lot of clutter --- style/shiny/single.css | 2 ++ 1 file changed, 2 insertions(+) diff --git a/style/shiny/single.css b/style/shiny/single.css index 73584d6..f83d73b 100644 --- a/style/shiny/single.css +++ b/style/shiny/single.css @@ -92,6 +92,7 @@ } } +/* .nsfw-label::after { content: url(../18_plus_white.svg); display: inline-block; @@ -103,6 +104,7 @@ :checked ~ .nsfw-label::after { content: url(../18_plus.svg); } +*/ #date { text-transform: lowercase; }