remove uses of head/tail

This commit is contained in:
rhiannon morris 2024-07-08 02:47:18 +02:00
parent 8daa6fa09f
commit 20963afa17
4 changed files with 81 additions and 37 deletions

View File

@ -19,6 +19,7 @@ import qualified Data.Text.Lazy as LText
import Data.Text.Lazy (toStrict) import Data.Text.Lazy (toStrict)
import Data.Foldable import Data.Foldable
import Data.Semigroup import Data.Semigroup
import Data.List.NonEmpty (NonEmpty)
data ChunkType = Lit | Var VarType deriving Show data ChunkType = Lit | Var VarType deriving Show
data VarType = data VarType =
@ -188,3 +189,7 @@ deriving via ShowBuild Integer instance CanBuild Integer
instance {-# OVERLAPPABLE #-} CanBuild a => CanBuild [a] where instance {-# OVERLAPPABLE #-} CanBuild a => CanBuild [a] where
build = foldMap \x -> build x <> "\n" build = foldMap \x -> build x <> "\n"
reindent n = fold . intersperse ("\n" <> replicateB n ' ') . map build reindent n = fold . intersperse ("\n" <> replicateB n ' ') . map build
instance CanBuild a => CanBuild (NonEmpty a) where
build = build . toList
reindent n = reindent n . toList

View File

@ -9,6 +9,7 @@ import Info hiding (Text)
import Data.Maybe (fromMaybe, mapMaybe) import Data.Maybe (fromMaybe, mapMaybe)
import Data.Text.Lazy (Text) import Data.Text.Lazy (Text)
import Data.Foldable
import System.FilePath import System.FilePath
@ -27,7 +28,9 @@ dependSingle' :: FilePath -> FilePath -> Info -> FilePath -> FilePath -> Bool
dependSingle' yamlDir indexFile info prefix build nsfw = dependSingle' yamlDir indexFile info prefix build nsfw =
[b|$page: $deps $indexFile $$(MAKEPAGES)|] [b|$page: $deps $indexFile $$(MAKEPAGES)|]
where 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 paths = map #path images
dls = mapMaybe #download images dls = mapMaybe #download images

View File

@ -12,7 +12,7 @@ module Info
readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters, readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters,
NoThumb (..), getThumb, thumbFile, pageFile, bigFile, NoThumb (..), getThumb, thumbFile, pageFile, bigFile,
-- ** Reexports -- ** Reexports
Date (..), Day (..), Text) Date (..), Day (..), Text, NonEmpty (..))
where where
import Date import Date
@ -28,8 +28,9 @@ import qualified Data.HashSet as HashSet
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Set (Set, (\\)) import Data.Set (Set, (\\))
import qualified Data.Set as 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 (nub, sortBy)
import Data.List.NonEmpty (NonEmpty (..), toList, nonEmpty)
import Data.Ord (comparing) import Data.Ord (comparing)
import Data.String (IsString) import Data.String (IsString)
import Data.Text (Text) import Data.Text (Text)
@ -38,6 +39,7 @@ import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
import qualified Data.YAML as YAML import qualified Data.YAML as YAML
import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension) import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension)
import Data.Bifunctor (second) import Data.Bifunctor (second)
import Data.Semigroup
data Info = data Info =
@ -98,8 +100,8 @@ data Image =
deriving (Eq, Show) deriving (Eq, Show)
data Images' a = data Images' a =
Uncat [a] -- ^ uncategorised Uncat (NonEmpty a) -- ^ uncategorised
| Cat [(Text, [a])] -- ^ categorised | Cat (NonEmpty (Text, NonEmpty a)) -- ^ categorised
deriving (Eq, Show, Functor, Foldable, Traversable) deriving (Eq, Show, Functor, Foldable, Traversable)
type Images = Images' Image 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" Link Bool where getField = not . #nsfw
instance HasField "sfw" Update 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 (Uncat is) = is
getField (Cat cats) = foldMap snd cats getField (Cat cats) = sconcat $ fmap snd cats
filterImages :: (a -> Bool) -> Images' a -> Images' a filterNE :: (a -> Bool) -> NonEmpty a -> Maybe (NonEmpty a)
filterImages p (Uncat is) = Uncat $ filter p is 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) = 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 getField = filterImages #sfw . #images
instance HasField "nsfwImages" Info Images where instance HasField "nsfwImages" Info (Maybe Images) where
getField = filterImages #nsfw . #images getField = filterImages #nsfw . #images
instance HasField "allNsfw" Info Bool where getField = null . #all . #sfwImages instance HasField "anySfw" Info Bool where getField = isJust . #sfwImages
instance HasField "allSfw" Info Bool where getField = null . #all . #nsfwImages instance HasField "anyNsfw" Info Bool where getField = isJust . #nsfwImages
instance HasField "anySfw" Info Bool where getField = not . #allNsfw instance HasField "allNsfw" Info Bool where getField = not . #anySfw
instance HasField "anyNsfw" Info Bool where getField = not . #allSfw instance HasField "allSfw" Info Bool where getField = not . #anyNsfw
instance HasField "sfwLinks" Info [Link] where instance HasField "sfwLinks" Info [Link] where
getField = filter #sfw . #links 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 :: Bool -> Info -> [Text]
tagsFor nsfw i = if nsfw then nub (#tags i <> #nsfwTags i) else #tags i tagsFor nsfw i = if nsfw then nub (#tags i <> #nsfwTags i) else #tags i
imagesFor :: Bool -> Info -> Images imagesFor :: Bool -> Info -> Maybe Images
imagesFor nsfw = if nsfw then #images else #sfwImages imagesFor nsfw = if nsfw then Just . #images else #sfwImages
linksFor :: Bool -> Info -> [Link] linksFor :: Bool -> Info -> [Link]
linksFor nsfw = if nsfw then #links else #sfwLinks linksFor nsfw = if nsfw then #links else #sfwLinks
@ -322,8 +330,14 @@ instance FromYAML Desc where
instance FromYAML DescField where parseYAML = withPair DescField instance FromYAML DescField where parseYAML = withPair DescField
imageList :: YAML.Node YAML.Pos -> YAML.Parser [Image] parseYAMLNE :: FromYAML a => YAML.Node YAML.Pos -> YAML.Parser (NonEmpty a)
imageList y = pure <$> unlabelledImage y <|> parseYAML y 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 instance FromYAML Image where
parseYAML y = unlabelledImage y <|> labelled y where parseYAML y = unlabelledImage y <|> labelled y where
@ -353,7 +367,10 @@ unlabelledImage' label' y = asStr y <|> asObj y
instance FromYAML Images where instance FromYAML Images where
parseYAML y = Uncat <$> imageList y parseYAML y = Uncat <$> imageList y
<|> Cat <$> YAML.withSeq "list of categories" fromPairs 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 instance FromYAML Link where
parseYAML = parseYAML =

View File

@ -1,3 +1,4 @@
{-# LANGUAGE PatternSynonyms #-}
module SinglePage (make) where module SinglePage (make) where
import Date import Date
@ -15,6 +16,7 @@ import qualified Data.Text.Lazy as Lazy
import System.FilePath (joinPath, splitPath) import System.FilePath (joinPath, splitPath)
import qualified Data.HashSet as Set import qualified Data.HashSet as Set
import Data.Traversable import Data.Traversable
import Data.Semigroup
-- | e.g. only nsfw images are present for a non-nsfw page -- | 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 -> IO Builder
make' root siteName prefix nsfw _dataDir dir make' root siteName prefix nsfw _dataDir dir
info@(Info {date, title, artist, bg}) = do 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)) "..") 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 buttonBar = makeButtonBar title $ addIds images
let allImages = #all images let image0 :| otherImages = #all images
let image0@(Image {path = path0, download = download0'}) = head allImages let Image {path = path0, download = download0'} = image0
let otherImages = tail allImages
let download0 = fromMaybe (bigFile path0) download0' let download0 = fromMaybe (bigFile path0) download0'
let path0' = pageFile path0 let path0' = pageFile path0
@ -229,27 +230,44 @@ makeDesc (LongDesc fs) = [b|@0
</div> </div>
|] |]
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 :: Traversable t => t Image -> t (Image, Text)
addIds = snd . mapAccumL makeId Set.empty where addIds = snd . mapAccumL makeId Set.empty where
makeId used img = (Set.insert newId used, (img, newId)) where makeId used img = (Set.insert newId used, (img, newId)) where
newId = head $ filter (\i -> not $ i `Set.member` used) ids newId = headI $ filterI (\i -> not $ i `Set.member` used) ids
ids = [toStrictText [b|$label$i|] | i <- "" : map show [0::Int ..]] ids = fmap (\i -> toStrictText [b|$label$i|]) suffixes
label = escId $ #label img label = escId $ #label img
pattern One :: a -> NonEmpty a
pattern One x = x :| []
makeButtonBar :: Strict.Text -> Images' (Image, Text) -> Builder makeButtonBar :: Strict.Text -> Images' (Image, Text) -> Builder
makeButtonBar title images = makeButtonBar title images =
case images of case images of
Uncat [] -> throw $ NoEligibleImages title Uncat (One _) -> ""
Uncat [_] -> "" Cat (One (_, One _)) -> ""
Cat [(_,[_])] -> "" Uncat imgs -> makeNav "uncat" $ makeAlts imgs
Uncat imgs -> makeNav "uncat" $ makeAlts imgs
Cat cats Cat cats
| all ((<= 1) . length . snd) cats -> | all ((== 1) . length . snd) cats ->
makeButtonBar title $ Uncat $ flatten cats makeButtonBar title $ Uncat $ flatten cats
| [(_, imgs)] <- cats -> | [(_, imgs)] <- cats ->
makeButtonBar title (Uncat imgs) makeButtonBar title (Uncat imgs)
| otherwise -> | otherwise ->
makeNav "cat" $ map (uncurry makeCat) cats makeNav "cat" $ fmap (uncurry makeCat) cats
where where
makeNav :: CanBuild b => Text -> b -> Builder makeNav :: CanBuild b => Text -> b -> Builder
makeNav cls inner = [b|@0 makeNav cls inner = [b|@0
@ -267,7 +285,7 @@ makeButtonBar title images =
<ul class="buttonbar bb-choice"> <ul class="buttonbar bb-choice">
$2.elems $2.elems
</ul> |] </ul> |]
where elems = map (uncurry altButton) imgs where elems = fmap (uncurry altButton) imgs
skipAll = skipAll =
if any (isJust . #warning . fst) images then if any (isJust . #warning . fst) images then
[b|@0 [b|@0
@ -278,9 +296,10 @@ makeButtonBar title images =
|] |]
else "" else ""
flatten :: [(Text, [(Image, a)])] -> [(Image, Text)] flatten :: NonEmpty (Text, NonEmpty (Image, a)) -> NonEmpty (Image, Text)
flatten cats = flatten =
addIds [(img {label = cat}) | (cat, is) <- cats, (img, _) <- is] addIds . sconcat .
fmap (\(t, is) -> fmap (\(i, _) -> i {label = t}) is)
altButton :: Image -> Text -> Builder altButton :: Image -> Text -> Builder
altButton img i = [b|@0 altButton img i = [b|@0