add support for categorised alts
This commit is contained in:
parent
e47b790242
commit
2ccfb72b22
4 changed files with 68 additions and 31 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" .!= []
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
Loading…
Reference in a new issue