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/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..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,10 +47,10 @@ 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})
- = 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 +62,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,35 +197,51 @@ makeDesc (LongDesc fs) = [b|@0
|]
-makeButtonBar :: Strict.Text -> [(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
- [] -> throw $ NoEligibleImages title
- [_] -> ""
- _ -> [b|@0
-
- |]
- where alts = map (\(i, (im, sz)) -> altButton i im sz) $ zip [0..] images
+ $2.elems
+ |]
+ where elems = map (\(img,sz,i) -> altButton img sz i) imgs
-altButton :: Int -> Image -> Size -> Builder
-altButton i 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 ""
- checked = if i == 0 then [b| checked|] else ""
- idLabel = escId label
path' = pageFile path
link = fromMaybe path download
warning' = ifJust warning \(escAttr -> w) -> [b| data-warning="$w"|]
@@ -297,7 +315,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,
diff --git a/style/shiny/single.css b/style/shiny/single.css
index 2646a4d..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; }
@@ -199,3 +201,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; }