add support for categorised alts

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

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|<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,24 +195,35 @@ makeDesc (LongDesc fs) = [b|@0
       </div>
     |]
 
-makeButtonBar :: Strict.Text -> [(Image, Size)] -> Builder
+makeButtonBar :: Strict.Text -> Images' (Image, Size) -> Builder
 makeButtonBar title images =
   case images of
-    []  -> throw $ NoEligibleImages title
-    [_] -> ""
-    _   -> [b|@0
-      <nav id=alts aria-label="alternate versions">
+    Uncat []        -> throw $ NoEligibleImages title
+    Uncat [_]       -> ""
+    Cat   [(_,[_])] -> ""
+    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
-        </ul>
-      </nav>
-      |]
- where alts = map (\(i, (im, sz)) -> altButton i im sz) $ zip [0..] images
+          $2.elems
+        </ul> |]
+     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
   <li$nsfwClass>
-    <input type=radio$checked name=variant id="$idLabel" value="$path'"
+    <input type=radio name=variant id="$idLabel" value="$path'"
            data-link="$link"$warning'
            data-width=$width data-height=$height>
     <label for="$idLabel"$nsfwLabelClass>$label</label>
@@ -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)

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,