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

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
 

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

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
+instance HasField "all" (Images' a) [a] where
-  getField = filter #sfw . #images
+  getField (Uncat is) = is
-instance HasField "nsfwImages" Info [Image] where
+  getField (Cat cats) = foldMap snd cats
-  getField = filter #nsfw . #images
+
-instance HasField "allNsfw" Info Bool where getField = null . #sfwImages
+filterImages :: (a -> Bool) -> Images' a -> Images' a
-instance HasField "allSfw" Info Bool where getField = null . #nsfwImages
+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

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})
+       Size {width = width0, height = height0}) : otherImages
-        = head images
+        = #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|<link rel=prefetch href=$path>|]
-  let prefetches = map (makePrefetch . #first) $ tail images
+  let prefetches = map (makePrefetch . #first) otherImages
 
   let makeWarning w = [b|@0
         <figcaption id=cw aria-role=button tabindex=0>
@@ -195,35 +197,51 @@ makeDesc (LongDesc fs) = [b|@0
       </div>
     |]
 
-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
+    Uncat []        -> throw $ NoEligibleImages title
-    [_] -> ""
+    Uncat [_]       -> ""
-    _   -> [b|@0
+    Cat   [(_,[_])] -> ""
-      <nav id=alts aria-label="alternate versions">
+    Uncat imgs      -> makeNav "uncat" $ makeAlts imgs
+    Cat   cats      -> makeNav "cat"   $ map (uncurry makeCat) cats
+ where
+   makeNav (cls :: Text) inner = [b|@0
+      <nav id=alts class=$cls aria-label="alternate versions">
+        $2.inner
+      </nav> |]
+   makeCat lbl imgs = [b|@0
+       <section>
+         <h3 class=alt-cat>$lbl</h3>
+         $0.alts
+       </section> |]
+     where alts = makeAlts imgs
+   makeAlts imgs = [b|@0
         <ul class="buttonbar bb-choice">
-          $4.alts
+          $2.elems
-        </ul>
+        </ul> |]
-      </nav>
+     where elems = map (\(img,sz,i) -> altButton img sz i) imgs
-      |]
- where alts = map (\(i, (im, sz)) -> altButton i im sz) $ zip [0..] images
 
-altButton :: Int -> Image -> Size -> Builder
+altButton :: Image -> Size -> Text -> Builder
-altButton i img size = [b|@0
+altButton img size i = [b|@0
   <li$nsfwClass>
-    <input type=radio$checked name=variant id="$idLabel" value="$path'"
+    <input type=radio name=variant id="$i" value="$path'"
            data-link="$link"$warning'
            data-width=$width data-height=$height>
-    <label for="$idLabel"$nsfwLabelClass>$label</label>
+    <label for="$i"$nsfwLabelClass>$label</label>
   |]
  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)

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,

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; }