diff --git a/make-pages/BuilderQQ.hs b/make-pages/BuilderQQ.hs index c0935da..46112cd 100644 --- a/make-pages/BuilderQQ.hs +++ b/make-pages/BuilderQQ.hs @@ -19,6 +19,7 @@ import qualified Data.Text.Lazy as LText import Data.Text.Lazy (toStrict) import Data.Foldable import Data.Semigroup +import Data.List.NonEmpty (NonEmpty) data ChunkType = Lit | Var VarType deriving Show data VarType = @@ -188,3 +189,7 @@ deriving via ShowBuild Integer instance CanBuild Integer instance {-# OVERLAPPABLE #-} CanBuild a => CanBuild [a] where build = foldMap \x -> build x <> "\n" reindent n = fold . intersperse ("\n" <> replicateB n ' ') . map build + +instance CanBuild a => CanBuild (NonEmpty a) where + build = build . toList + reindent n = reindent n . toList diff --git a/make-pages/Depend.hs b/make-pages/Depend.hs index 534f91d..d1da0e9 100644 --- a/make-pages/Depend.hs +++ b/make-pages/Depend.hs @@ -9,6 +9,7 @@ import Info hiding (Text) import Data.Maybe (fromMaybe, mapMaybe) import Data.Text.Lazy (Text) +import Data.Foldable import System.FilePath @@ -27,7 +28,9 @@ dependSingle' :: FilePath -> FilePath -> Info -> FilePath -> FilePath -> Bool dependSingle' yamlDir indexFile info prefix build nsfw = [b|$page: $deps $indexFile $$(MAKEPAGES)|] where - images = #all if nsfw then #images info else #sfwImages info + images = + maybe [] (toList . #all) $ + if nsfw then Just $ #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 4003137..b8eb425 100644 --- a/make-pages/Info.hs +++ b/make-pages/Info.hs @@ -12,7 +12,7 @@ module Info readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters, NoThumb (..), getThumb, thumbFile, pageFile, bigFile, -- ** Reexports - Date (..), Day (..), Text) + Date (..), Day (..), Text, NonEmpty (..)) where import Date @@ -28,8 +28,9 @@ import qualified Data.HashSet as HashSet import qualified Data.Map.Strict as Map import Data.Set (Set, (\\)) import qualified Data.Set as Set -import Data.Maybe (isJust, isNothing, fromMaybe, mapMaybe) +import Data.Maybe (isJust, isNothing, fromMaybe, mapMaybe, catMaybes) import Data.List (nub, sortBy) +import Data.List.NonEmpty (NonEmpty (..), toList, nonEmpty) import Data.Ord (comparing) import Data.String (IsString) import Data.Text (Text) @@ -38,6 +39,7 @@ import Data.YAML (FromYAML (..), (.:), (.:?), (.!=)) import qualified Data.YAML as YAML import System.FilePath ((), takeBaseName, takeExtension, splitExtension) import Data.Bifunctor (second) +import Data.Semigroup data Info = @@ -98,8 +100,8 @@ data Image = deriving (Eq, Show) data Images' a = - Uncat [a] -- ^ uncategorised - | Cat [(Text, [a])] -- ^ categorised + Uncat (NonEmpty a) -- ^ uncategorised + | Cat (NonEmpty (Text, NonEmpty a)) -- ^ categorised deriving (Eq, Show, Functor, Foldable, Traversable) type Images = Images' Image @@ -125,23 +127,29 @@ 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 "all" (Images' a) [a] where +instance HasField "all" (Images' a) (NonEmpty a) where getField (Uncat is) = is - getField (Cat cats) = foldMap snd cats + getField (Cat cats) = sconcat $ fmap snd cats -filterImages :: (a -> Bool) -> Images' a -> Images' a -filterImages p (Uncat is) = Uncat $ filter p is +filterNE :: (a -> Bool) -> NonEmpty a -> Maybe (NonEmpty a) +filterNE p = nonEmpty . filter p . toList + +catMaybesNE :: NonEmpty (Maybe a) -> Maybe (NonEmpty a) +catMaybesNE = nonEmpty . catMaybes . toList + +filterImages :: (a -> Bool) -> Images' a -> Maybe (Images' a) +filterImages p (Uncat is) = Uncat <$> filterNE p is filterImages p (Cat cats) = - Cat $ filter (not . null . snd) $ map (second $ filter p) cats + fmap Cat $ catMaybesNE $ fmap (traverse $ filterNE p) cats -instance HasField "sfwImages" Info Images where +instance HasField "sfwImages" Info (Maybe Images) where getField = filterImages #sfw . #images -instance HasField "nsfwImages" Info Images where +instance HasField "nsfwImages" Info (Maybe 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 +instance HasField "anySfw" Info Bool where getField = isJust . #sfwImages +instance HasField "anyNsfw" Info Bool where getField = isJust . #nsfwImages +instance HasField "allNsfw" Info Bool where getField = not . #anySfw +instance HasField "allSfw" Info Bool where getField = not . #anyNsfw instance HasField "sfwLinks" Info [Link] where getField = filter #sfw . #links @@ -212,8 +220,8 @@ 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 -> Images -imagesFor nsfw = if nsfw then #images else #sfwImages +imagesFor :: Bool -> Info -> Maybe Images +imagesFor nsfw = if nsfw then Just . #images else #sfwImages linksFor :: Bool -> Info -> [Link] linksFor nsfw = if nsfw then #links else #sfwLinks @@ -322,8 +330,14 @@ instance FromYAML Desc where instance FromYAML DescField where parseYAML = withPair DescField -imageList :: YAML.Node YAML.Pos -> YAML.Parser [Image] -imageList y = pure <$> unlabelledImage y <|> parseYAML y +parseYAMLNE :: FromYAML a => YAML.Node YAML.Pos -> YAML.Parser (NonEmpty a) +parseYAMLNE = YAML.withSeq "non-empty sequence" \ys -> + case nonEmpty ys of + Just ys' -> traverse YAML.parseYAML ys' + Nothing -> fail "expected non-empty sequence" + +imageList :: YAML.Node YAML.Pos -> YAML.Parser (NonEmpty Image) +imageList y = pure <$> unlabelledImage y <|> parseYAMLNE y instance FromYAML Image where parseYAML y = unlabelledImage y <|> labelled y where @@ -353,7 +367,10 @@ unlabelledImage' label' y = asStr y <|> asObj y 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 + where + fromPairs (nonEmpty -> Just xs) = + traverse (withPairM \label -> fmap (label,) . imageList) xs + fromPairs _ = YAML.typeMismatch "non-empty list" y instance FromYAML Link where parseYAML = diff --git a/make-pages/SinglePage.hs b/make-pages/SinglePage.hs index 59faeae..a75ddfb 100644 --- a/make-pages/SinglePage.hs +++ b/make-pages/SinglePage.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} module SinglePage (make) where import Date @@ -15,6 +16,7 @@ import qualified Data.Text.Lazy as Lazy import System.FilePath (joinPath, splitPath) import qualified Data.HashSet as Set import Data.Traversable +import Data.Semigroup -- | e.g. only nsfw images are present for a non-nsfw page @@ -41,7 +43,7 @@ make' :: Text -> Text -> FilePath -> Bool -> FilePath -> FilePath -> Info -> IO Builder make' root siteName prefix nsfw _dataDir dir info@(Info {date, title, artist, bg}) = do - let images = imagesFor nsfw info + images <- maybe (throw $ NoEligibleImages title) pure $ imagesFor nsfw info let undir = joinPath (replicate (length (splitPath dir)) "..") @@ -49,9 +51,8 @@ make' root siteName prefix nsfw _dataDir dir let buttonBar = makeButtonBar title $ addIds images - let allImages = #all images - let image0@(Image {path = path0, download = download0'}) = head allImages - let otherImages = tail allImages + let image0 :| otherImages = #all images + let Image {path = path0, download = download0'} = image0 let download0 = fromMaybe (bigFile path0) download0' let path0' = pageFile path0 @@ -229,27 +230,44 @@ makeDesc (LongDesc fs) = [b|@0 |] + +data Inf a = a :> Inf a deriving Functor + +headI :: Inf a -> a +headI (x :> _) = x + +suffixes :: Inf String +suffixes = "" :> go 0 where + go :: Int -> Inf String + go i = show i :> go (i + 1) + +filterI :: (a -> Bool) -> Inf a -> Inf a +filterI p (x :> xs) = if p x then x :> filterI p xs else filterI p xs + addIds :: Traversable t => t Image -> t (Image, Text) addIds = snd . mapAccumL makeId Set.empty where makeId used img = (Set.insert newId used, (img, newId)) where - newId = head $ filter (\i -> not $ i `Set.member` used) ids - ids = [toStrictText [b|$label$i|] | i <- "" : map show [0::Int ..]] + newId = headI $ filterI (\i -> not $ i `Set.member` used) ids + ids = fmap (\i -> toStrictText [b|$label$i|]) suffixes label = escId $ #label img + +pattern One :: a -> NonEmpty a +pattern One x = x :| [] + makeButtonBar :: Strict.Text -> Images' (Image, Text) -> Builder makeButtonBar title images = case images of - Uncat [] -> throw $ NoEligibleImages title - Uncat [_] -> "" - Cat [(_,[_])] -> "" - Uncat imgs -> makeNav "uncat" $ makeAlts imgs + Uncat (One _) -> "" + Cat (One (_, One _)) -> "" + Uncat imgs -> makeNav "uncat" $ makeAlts imgs Cat cats - | all ((<= 1) . length . snd) cats -> + | all ((== 1) . length . snd) cats -> makeButtonBar title $ Uncat $ flatten cats | [(_, imgs)] <- cats -> makeButtonBar title (Uncat imgs) | otherwise -> - makeNav "cat" $ map (uncurry makeCat) cats + makeNav "cat" $ fmap (uncurry makeCat) cats where makeNav :: CanBuild b => Text -> b -> Builder makeNav cls inner = [b|@0 @@ -267,7 +285,7 @@ makeButtonBar title images = |] - where elems = map (uncurry altButton) imgs + where elems = fmap (uncurry altButton) imgs skipAll = if any (isJust . #warning . fst) images then [b|@0 @@ -278,9 +296,10 @@ makeButtonBar title images = |] else "" -flatten :: [(Text, [(Image, a)])] -> [(Image, Text)] -flatten cats = - addIds [(img {label = cat}) | (cat, is) <- cats, (img, _) <- is] +flatten :: NonEmpty (Text, NonEmpty (Image, a)) -> NonEmpty (Image, Text) +flatten = + addIds . sconcat . + fmap (\(t, is) -> fmap (\(i, _) -> i {label = t}) is) altButton :: Image -> Text -> Builder altButton img i = [b|@0