Compare commits

...

4 Commits

Author SHA1 Message Date
Rhiannon Morris 2d27465ffc remove the individual 18+ badges from alts
with the badge on the gallery, and the 'are you an adult?' popup,
and the cw before showing the image, they're probably unnecessary
and they add a lot of clutter
2021-08-23 16:38:53 +02:00
Rhiannon Morris 004e43f52f ensure ids are unique 2021-08-23 16:35:55 +02:00
Rhiannon Morris 8e5e066699 style the categories 2021-08-23 16:35:36 +02:00
Rhiannon Morris 2ccfb72b22 add support for categorised alts 2021-08-23 16:35:19 +02:00
6 changed files with 97 additions and 35 deletions

View File

@ -1,7 +1,7 @@
{-# LANGUAGE TemplateHaskell #-}
module BuilderQQ
(b,
Builder, toLazyText, fromText, fromString, fromChar,
Builder, toStrictText, toLazyText, fromText, fromString, fromChar,
textMap, ifJust, escId, escAttr)
where

View File

@ -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

View File

@ -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

View File

@ -14,6 +14,8 @@ import qualified Data.Text.Lazy as Lazy
import System.FilePath (joinPath, splitPath, (</>))
import qualified System.Process as Proc
import Text.Read (readMaybe)
import qualified Data.HashSet as Set
import Data.Traversable
-- | e.g. only nsfw images are present for a non-nsfw page
@ -45,10 +47,10 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do
let formattedDate = formatLong date
let buttonBar = makeButtonBar title images
let buttonBar = makeButtonBar title $ addIds 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 +62,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,35 +197,51 @@ makeDesc (LongDesc fs) = [b|@0
</div>
|]
makeButtonBar :: Strict.Text -> [(Image, Size)] -> Builder
addIds :: Images' (Image, a) -> Images' (Image, a, Text)
addIds = snd . mapAccumL makeId Set.empty where
makeId used (img, x) = (Set.insert newId used, (img, x, newId)) where
newId = head $ filter (\i -> not $ i `Set.member` used) ids
ids = [toStrictText [b|$label$i|] | i <- "" : map show [0::Int ..]]
label = escId $ #label img
makeButtonBar :: Strict.Text -> Images' (Image, Size, Text) -> 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 (\(img,sz,i) -> altButton img sz i) imgs
altButton :: Int -> Image -> Size -> Builder
altButton i img size = [b|@0
altButton :: Image -> Size -> Text -> Builder
altButton img size i = [b|@0
<li$nsfwClass>
<input type=radio$checked name=variant id="$idLabel" value="$path'"
<input type=radio name=variant id="$i" value="$path'"
data-link="$link"$warning'
data-width=$width data-height=$height>
<label for="$idLabel"$nsfwLabelClass>$label</label>
<label for="$i"$nsfwLabelClass>$label</label>
|]
where
Image {label, path, nsfw, warning, download} = img
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
warning' = ifJust warning \(escAttr -> w) -> [b| data-warning="$w"|]
@ -297,7 +315,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)

View File

@ -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,

View File

@ -92,6 +92,7 @@
}
}
/*
.nsfw-label::after {
content: url(../18_plus_white.svg);
display: inline-block;
@ -103,6 +104,7 @@
:checked ~ .nsfw-label::after {
content: url(../18_plus.svg);
}
*/
#date { text-transform: lowercase; }
@ -199,3 +201,18 @@ footer {
font-size: 150%;
}
}
#alts {
margin: 1.5em 0;
text-align: center;
}
.cat :is(h3,ul) { margin: 0; }
#alts h3 {
font-weight: 600;
display: inline;
padding-right: 0.5em;
}
#alts ul { display: inline flex; }