remove uses of head/tail
This commit is contained in:
parent
8daa6fa09f
commit
20963afa17
4 changed files with 81 additions and 37 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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
|
|||
</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 = 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 =
|
|||
<ul class="buttonbar bb-choice">
|
||||
$2.elems
|
||||
</ul> |]
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue