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,