rhi
/
gallery
1
0
Fork 0
Code Issues 5 Pull Requests 1 Releases Wiki Activity

remove the reindent stuff. it does not matter

This commit is contained in:
rhiannon morris 2024-08-18 07:37:58 +02:00
parent 47d0d6a2cb
commit 7745722009
7 changed files with 123 additions and 238 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

189
make-pages/BuilderQQ.hs
View File

@ -1,184 +1,72 @@
{-# LANGUAGE PatternSynonyms, TemplateHaskell #-} {-# LANGUAGE PatternSynonyms, TemplateHaskell #-}
module BuilderQQ module BuilderQQ
(b, (b, Builder, toStrictText, toLazyText, fromText, fromString,
Builder, toStrictText, toLazyText, fromText, fromString, fromChar, ifJust, escId, escAttr, CanBuild (..))
textMap, ifJust, escId, escAttr, CanBuild (..))
where where
import Data.Char (isLower, isSpace, isDigit, isAlphaNum) import Data.Char (isSpace, isAlphaNum)
import Language.Haskell.TH import Language.Haskell.TH
import Language.Haskell.TH.Quote import Language.Haskell.TH.Quote
import Data.List (intersperse) import Data.List (dropWhileEnd)
import Data.Maybe (mapMaybe, fromMaybe) import Data.Maybe (mapMaybe, fromMaybe)
import Data.Text.Lazy.Builder import Data.Text.Lazy.Builder
(Builder, fromText, fromLazyText, fromString, singleton, toLazyText) (Builder, fromText, fromLazyText, fromString, singleton, toLazyText)
import Text.Read (readMaybe) import qualified Data.Text as Strict
import Data.Text (Text) import qualified Data.Text.Lazy as Lazy
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LText
import Data.Text.Lazy (toStrict) import Data.Text.Lazy (toStrict)
import Data.Foldable import Data.List.NonEmpty (NonEmpty, toList)
import Data.Semigroup
import Data.List.NonEmpty (NonEmpty)
data ChunkType = Lit | Var VarType deriving Show data Chunk = Lit String | Var String
data VarType =
Plain
| Reindent !Int
deriving Show
type Chunk = (ChunkType, Text)
indent :: Int -> LText.Text -> Builder parseB :: String -> ExpQ
indent i str parseB = toExpQ . reverse . go "" [] . dropWhileEnd isSpace where
| LText.all isSpace str = "" go acc cs [] = addLit acc cs
| otherwise = replicateB i ' ' <> fromLazyText str go acc cs ('$':'&':rest) = go acc cs rest -- $&: expands to nothing
go acc cs ('$':'$':rest) = go ('$' : acc) cs rest -- $$: expands to one $
go acc cs ('$':rest) = go "" (Var var : addLit acc cs) rest' -- $var
where (var, rest') = span isIdChar rest
go acc cs (c:rest) = go (c : acc) cs rest
reindentB :: Int -> Builder -> Builder addLit l cs = if null l then cs else Lit (reverse l) : cs
reindentB i (toLazyText -> str) = isIdChar c = isAlphaNum c || c `elem` ("_'" :: String)
fold $ intersperse "\n" $
map2 (fromLazyText . dropIndent) (indent i . dropIndent) ls
where
ls = dropWhile (LText.all isSpace) $ LText.lines str
ls' = filter (LText.any $ not . isSpace) ls
dropIndent = LText.drop minIndent toExpQ cs = [|mconcat $(listE $ mapMaybe chunk1 cs) :: Builder|]
chunk1 (Lit lit) = Just $ stringE lit
minIndent = chunk1 (Var name) = Just $ [|build $(varE $ mkName name)|]
getMin $ fromMaybe 0 $ foldMap (Just . Min . indentOf) ls'
indentOf = go 0 where
go n (' ' :.. cs) = go (n + 1) cs
go n ('\t' :.. cs) = go (((n `mod` 8) + 1) * 8) cs
go n _ = n
map2 _ _ [] = []
map2 f g (x:xs) = f x : map g xs
chunks :: Text -> [Chunk] toStrictText :: Builder -> Strict.Text
chunks = reverse . go "" [] . trimEnd where
go acc cs NilT = if Text.null acc' then cs else (Lit, acc') : cs
where acc' = toStrictText acc
-- $&: expands to nothing
go acc cs ('$' :. '&' :. rest) = go acc cs rest
-- $$: expands to one $
go acc cs ('$' :. '$' :. rest) = go (acc <> "$") cs rest
-- $n.var (n a number): expands to builder var indented by n
go acc cs ('$' :. rest@(d :. _)) | isDigit d =
go "" ((Var (Reindent n), var) : lit acc : cs) rest3
where
(read . Text.unpack -> n, rest2) = Text.span isDigit rest
(var, rest3) = splitVar $ Text.tail rest2
-- $var: expands to that var's contents
go acc cs ('$' :. rest) =
go "" ((Var Plain, var) : lit acc : cs) rest2
where (var, rest2) = splitVar rest
go acc cs (c :. rest) = go (acc <> singleton c) cs rest
splitVar s
| (var@(v :. _), s') <- Text.span isIdChar s,
isLower v || v == '_'
= (var, s')
splitVar _ = error "invalid variable name"
isIdChar c = isAlphaNum c || c `elem` ("_'" :: String)
lit s = (Lit, toStrictText s)
trimEnd = Text.dropWhileEnd isSpace
chunksWithReindent :: String -> [Chunk]
chunksWithReindent ('@':str)
| [(n',rest)] <- lex str,
Just n <- readMaybe n'
= chunks $ toStrictText $ reindent n $ Text.pack rest
chunksWithReindent str = chunks $ Text.pack str
toStrictText :: Builder -> Text
toStrictText = toStrict . toLazyText toStrictText = toStrict . toLazyText
chunksToExpQ :: [Chunk] -> ExpQ
chunksToExpQ cs = [|mconcat $es :: Builder|] where
es = listE $ mapMaybe chunk1 cs
chunk1 (Lit, "") = Nothing
chunk1 (Lit, lit) = Just $ stringE $ Text.unpack lit
chunk1 (Var t, name) = Just $ case t of
Plain -> [|build $var|]
Reindent n -> [|reindent n $var|]
where var = varE (mkName $ Text.unpack name)
replicateB :: Int -> Char -> Builder
replicateB n c = fromText $ Text.replicate n $ Text.singleton c
b :: QuasiQuoter b :: QuasiQuoter
b = QuasiQuoter { b = QuasiQuoter parseB undefined undefined undefined
quoteExp = chunksToExpQ . chunksWithReindent,
quotePat = error "can't use in a pattern",
quoteType = error "can't use in a type",
quoteDec = error "can't use at top level"
}
pattern NilT :: Text
pattern NilT <- (Text.null -> True)
where NilT = ""
infixr 5 :.
pattern (:.) :: Char -> Text -> Text
pattern c :. t <- (Text.uncons -> Just (c, t))
where c :. t = Text.cons c t
{-# COMPLETE NilT, (:.) :: Text #-}
infixr 5 :..
pattern (:..) :: Char -> LText.Text -> LText.Text
pattern c :.. t <- (LText.uncons -> Just (c, t))
where c :.. t = LText.cons c t
fromChar :: Char -> Builder
fromChar = singleton
textMap :: (Char -> Builder) -> Text -> Builder
textMap f = Text.foldl' (\buf c -> buf <> f c) mempty
ifJust :: Monoid b => Maybe a -> (a -> b) -> b ifJust :: Monoid b => Maybe a -> (a -> b) -> b
ifJust x f = maybe mempty f x ifJust x f = maybe mempty f x
escId :: Text -> Builder escId :: Strict.Text -> Builder
escId = foldMap esc1 . Text.unpack where escId = foldMap esc1 . Strict.unpack where
esc1 c | isSpace c = "" esc1 c | isSpace c = ""
| latin1Special c = "_" | latin1Special c = "_"
| otherwise = fromChar c | otherwise = singleton c
latin1Special c = latin1Special c =
c <= 'ÿ' && not (isAlphaNum c) && c /= '-' c <= 'ÿ' && not (isAlphaNum c) && c /= '-'
escAttr :: Text -> Builder escAttr :: Strict.Text -> Builder
escAttr = foldMap esc1 . Text.unpack where escAttr = foldMap esc1 . Strict.unpack where
esc1 '<' = "&lt;" esc1 c = fromMaybe (singleton c) $ lookup c
esc1 '>' = "&gt;" [('<', "&lt;"), ('>', "&gt;"), ('"', "&quot;"), ('\'', "&apos;")]
esc1 '"' = "&quot;"
esc1 '\'' = "&apos;"
esc1 c = fromChar c
class CanBuild a where class CanBuild a where build :: a -> Builder
build :: a -> Builder
reindent :: Int -> a -> Builder
reindent i = reindentB i . build
instance CanBuild Builder where build = id instance CanBuild Builder where build = id
instance CanBuild Text where build = fromText instance CanBuild Strict.Text where build = fromText
instance CanBuild LText.Text where build = fromLazyText instance CanBuild Lazy.Text where build = fromLazyText
instance CanBuild Char where build = singleton instance CanBuild Char where build = singleton
instance CanBuild String where build = fromString instance CanBuild String where build = fromString
newtype ShowBuild a = ShowBuild a deriving newtype Show newtype ShowBuild a = ShowBuild a deriving newtype Show
instance Show a => CanBuild (ShowBuild a) where build = build . show instance Show a => CanBuild (ShowBuild a) where build = build . show
@ -188,8 +76,5 @@ 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
instance CanBuild a => CanBuild (NonEmpty a) where instance CanBuild a => CanBuild (NonEmpty a) where build = build . toList
build = build . toList
reindent n = reindent n . toList

38
make-pages/Depend.hs
View File

@ -56,19 +56,19 @@ dependGallery ginfo index infos build data_ tmp =
dependGallery' :: GalleryInfo -> FilePath -> [(FilePath, Info)] dependGallery' :: GalleryInfo -> FilePath -> [(FilePath, Info)]
-> FilePath -> FilePath -> FilePath -> Builder -> FilePath -> FilePath -> FilePath -> Builder
dependGallery' (GalleryInfo {prefix, filters}) dependGallery' (GalleryInfo {prefix, filters})
indexFile infos' build data_ tmp = [b|@0 indexFile infos' build data_ tmp = [b|
$index: $gallery $index: $gallery
$gallery: $pages' $files' $rss $indexFile $$(MAKEPAGES) $gallery: $pages' $files' $rss $indexFile $$(MAKEPAGES)
$$(call gallery,$indexFile,$prefix) $$(call gallery,$indexFile,$prefix)
$rss: $files' $indexFile $$(MAKEPAGES) $rss: $files' $indexFile $$(MAKEPAGES)
$$(call rss,$indexFile,$prefix,$data_) $$(call rss,$indexFile,$prefix,$data_)
$rules $rules
$incs $incs
|] |]
where where
infos = filter (matchFilters filters . snd) infos' infos = filter (matchFilters filters . snd) infos'
@ -96,19 +96,19 @@ makeRules :: FilePath -- ^ prefix
-> FilePath -- ^ data dir -> FilePath -- ^ data dir
-> FilePath -- ^ tmp dir -> FilePath -- ^ tmp dir
-> Builder -> Builder
makeRules prefix indexFile filters build data_ tmp = [b|@0 makeRules prefix indexFile filters build data_ tmp = [b|
$buildPrefix/%/index.html: $data_/%/info.yaml $$(MAKEPAGES) $buildPrefix/%/index.html: $data_/%/info.yaml $$(MAKEPAGES)
$$(call single,$data_,$prefix,$indexFile,$flags) $$(call single,$data_,$prefix,$indexFile,$flags)
$tmpPrefix/%.mk: $data_/%/info.yaml $$(MAKEPAGES) $tmpPrefix/%.mk: $data_/%/info.yaml $$(MAKEPAGES)
$$(call depend-single,$prefix,$indexFile,$build,$data_,$flags) $$(call depend-single,$prefix,$indexFile,$build,$data_,$flags)
$buildPrefix/%: $tmp/% $buildPrefix/%: $tmp/%
$$(call copy,-l) $$(call copy,-l)
$buildPrefix/%: $data_/% $buildPrefix/%: $data_/%
$$(call copy) $$(call copy)
|] |]
where where
buildPrefix = build </> prefix buildPrefix = build </> prefix
tmpPrefix = tmp </> prefix tmpPrefix = tmp </> prefix

20
make-pages/GalleryPage.hs
View File

@ -22,7 +22,7 @@ make root ginfo infos = toLazyText $ make' root ginfo infos
make' :: Text -> GalleryInfo -> [(FilePath, Info)] -> Builder make' :: Text -> GalleryInfo -> [(FilePath, Info)] -> Builder
make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0 make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|
<!DOCTYPE html> <!DOCTYPE html>
<html lang=en> <html lang=en>
<meta charset=utf-8> <meta charset=utf-8>
@ -42,11 +42,11 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
<meta name=robots content='noai,noimageai'> <meta name=robots content='noai,noimageai'>
<script src=/script/gallery.js type=module></script> <script src=/script/gallery.js type=module></script>
$0.nsfwScript $nsfwScript
<title>$title</title> <title>$title</title>
$0.nsfwDialog $nsfwDialog
<div class=page> <div class=page>
<header> <header>
@ -61,12 +61,12 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
<div> <div>
<h3>show only</h3> <h3>show only</h3>
<ul id=require class=filterlist> <ul id=require class=filterlist>
$10.requireFilters $requireFilters
</ul> </ul>
<h3>exclude</h3> <h3>exclude</h3>
<ul id=exclude class=filterlist> <ul id=exclude class=filterlist>
$10.excludeFilters $excludeFilters
</ul> </ul>
<ul id=filterstuff> <ul id=filterstuff>
@ -81,7 +81,7 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
<main> <main>
<ul class=grid> <ul class=grid>
$6.items $items
</ul> </ul>
</main> </main>
</div> </div>
@ -121,7 +121,7 @@ groupOnKey f (x:xs) = (fx, x:yes) : groupOnKey f no where
(yes, no) = span (\y -> fx == f y) xs (yes, no) = span (\y -> fx == f y) xs
makeFilter :: Text -> HashSet Text -> Text -> Int -> Builder makeFilter :: Text -> HashSet Text -> Text -> Int -> Builder
makeFilter prefix initial tag count = [b|@0 makeFilter prefix initial tag count = [b|
<li$hidden> <li$hidden>
<input type=checkbox id="$id'" value="$tag"$checked> <input type=checkbox id="$id'" value="$tag"$checked>
<label for="$id'" data-count=$count>$tag</label> <label for="$id'" data-count=$count>$tag</label>
@ -136,17 +136,17 @@ makeYearItems :: Bool -- ^ nsfw
-> Int -- ^ year -> Int -- ^ year
-> [(FilePath, Info)] -> [(FilePath, Info)]
-> Builder -> Builder
makeYearItems nsfw year infos = [b|@0 makeYearItems nsfw year infos = [b|
<li class="item year-marker" id="marker-$year"> <li class="item year-marker" id="marker-$year">
<span class=year-text>$year'</span> <span class=year-text>$year'</span>
$0.items $items
|] |]
where where
items = map (uncurry $ makeItem nsfw) infos items = map (uncurry $ makeItem nsfw) infos
year' = show year & foldMap \c -> [b|<span class=y>$c</span>|] year' = show year & foldMap \c -> [b|<span class=y>$c</span>|]
makeItem :: Bool -> FilePath -> Info -> Builder makeItem :: Bool -> FilePath -> Info -> Builder
makeItem nsfw file info@(Info {bg}) = [b|@0 makeItem nsfw file info@(Info {bg}) = [b|
<li class="item post$nsfw'" data-year=$year' data-updated="$updated'" <li class="item post$nsfw'" data-year=$year' data-updated="$updated'"
data-tags="$tags'"> data-tags="$tags'">
<a href="$dir"> <a href="$dir">

24
make-pages/IndexPage.hs
View File

@ -9,7 +9,7 @@ make :: Text -> IndexInfo -> Lazy.Text
make root info = toLazyText $ make' root info make root info = toLazyText $ make' root info
make' :: Text -> IndexInfo -> Builder make' :: Text -> IndexInfo -> Builder
make' root (IndexInfo {title, desc, galleries, links, footer}) = [b|@0 make' root (IndexInfo {title, desc, galleries, links, footer}) = [b|
<!DOCTYPE html> <!DOCTYPE html>
<html lang=en> <html lang=en>
<meta charset=utf-8> <meta charset=utf-8>
@ -37,47 +37,47 @@ make' root (IndexInfo {title, desc, galleries, links, footer}) = [b|@0
</header> </header>
<main> <main>
$4.galleryList $galleryList
$4.linkList $linkList
</main> </main>
$2.footer' $footer'
</div> </div>
|] |]
where where
galleryList = if null galleries then "" else [b|@0 galleryList = if null galleries then "" else [b|
<nav aria-label="gallery list"> <nav aria-label="gallery list">
<ul id=gallery-list class=list> <ul id=gallery-list class=list>
$4.items $items
</ul> </ul>
</nav> </nav>
|] |]
where items = map makeItem galleries where items = map makeItem galleries
linkList = if null links then "" else [b|@0 linkList = if null links then "" else [b|
<nav aria-label="other links"> <nav aria-label="other links">
<ul id=link-list class=list> <ul id=link-list class=list>
$4.items $items
</ul> </ul>
</nav> </nav>
|] |]
where items = map makeLink links where items = map makeLink links
footer' = case footer of footer' = case footer of
Nothing -> "" Nothing -> ""
Just f -> [b|@0 Just f -> [b|
<footer> <footer>
$2.f $f
</footer> </footer>
|] |]
url = [b|$root|] url = [b|$root|]
makeItem :: GalleryInfo -> Builder makeItem :: GalleryInfo -> Builder
makeItem (GalleryInfo {title, desc, prefix, filters}) = [b|@0 makeItem (GalleryInfo {title, desc, prefix, filters}) = [b|
<li$nsfw><a href=$prefix title="$desc">$title</a></li> <li$nsfw><a href=$prefix title="$desc">$title</a></li>
|] |]
where nsfw = if hasNsfw filters then [b| class=nsfw|] else "" where nsfw = if hasNsfw filters then [b| class=nsfw|] else ""
makeLink :: Link -> Builder makeLink :: Link -> Builder
makeLink (Link {title, url, nsfw}) = [b|@0 makeLink (Link {title, url, nsfw}) = [b|
<li$nsfw'><a href=$url>$title</a> <li$nsfw'><a href=$url>$title</a>
|] |]
where nsfw' = if nsfw then [b| class=nsfw|] else "" where nsfw' = if nsfw then [b| class=nsfw|] else ""

2
make-pages/NsfwWarning.hs
View File

@ -16,7 +16,7 @@ script (Just _) = [b|<script src=/script/nsfw-warning.js type=module></script>|]
dialog :: Maybe What -> Builder dialog :: Maybe What -> Builder
dialog Nothing = "" dialog Nothing = ""
dialog (Just what) = [b|@0 dialog (Just what) = [b|
<dialog id=nsfw-dialog> <dialog id=nsfw-dialog>
<h1>cw: lewd art</h1> <h1>cw: lewd art</h1>
<img src=/style/stop_hand.svg> <img src=/style/stop_hand.svg>

14
make-pages/RSS.hs
View File

@ -24,7 +24,7 @@ make root name ginfo output infos =
make' :: Strict.Text -> Strict.Text -> GalleryInfo make' :: Strict.Text -> Strict.Text -> GalleryInfo
-> Maybe FilePath -> [(FilePath, Info)] -> Builder -> Maybe FilePath -> [(FilePath, Info)] -> Builder
make' root name ginfo@(GalleryInfo {title, desc, prefix}) output infos = [b|@0 make' root name ginfo@(GalleryInfo {title, desc, prefix}) output infos = [b|
<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="UTF-8"?>
<rss version="2.0"> <rss version="2.0">
<channel> <channel>
@ -33,7 +33,7 @@ make' root name ginfo@(GalleryInfo {title, desc, prefix}) output infos = [b|@0
<description>$desc</description> <description>$desc</description>
$selflink $selflink
$4.items $items
</channel> </channel>
</rss> </rss>
|] |]
@ -48,7 +48,7 @@ make' root name ginfo@(GalleryInfo {title, desc, prefix}) output infos = [b|@0
Just o -> [b|<link href="$link/$o" rel="self" />|] Just o -> [b|<link href="$link/$o" rel="self" />|]
makeItem :: Strict.Text -> FilePath -> Bool -> FilePath -> Info -> Builder makeItem :: Strict.Text -> FilePath -> Bool -> FilePath -> Info -> Builder
makeItem root prefix nsfw path info@(Info {title}) = [b|@4 makeItem root prefix nsfw path info@(Info {title}) = [b|
<item> <item>
<title>$title$suffix</title> <title>$title$suffix</title>
<link>$link</link> <link>$link</link>
@ -58,11 +58,11 @@ makeItem root prefix nsfw path info@(Info {title}) = [b|@4
</item> </item>
|] |]
where where
body = [b|@6 body = [b|
<description> <![CDATA[ <description> <![CDATA[
$8.image $image
$8.artist $artist
$8.desc $desc
]]> </description> ]]> </description>
|] |]

74
make-pages/SinglePage.hs
View File

@ -66,7 +66,7 @@ make' root siteName prefix nsfw _dataDir dir
where path' = bigFile img where path' = bigFile img
let prefetches = map makePrefetch otherImages let prefetches = map makePrefetch otherImages
let makeWarning w = [b|@0 let makeWarning w = [b|
<figcaption id=cw aria-role=button tabindex=0> <figcaption id=cw aria-role=button tabindex=0>
<span id=cw-text>$w</span> <span id=cw-text>$w</span>
</figcaption> </figcaption>
@ -77,7 +77,7 @@ make' root siteName prefix nsfw _dataDir dir
let bgStyle = case bg of let bgStyle = case bg of
Default -> "" Default -> ""
NoBorder -> [b|@0 NoBorder -> [b|
<style> <style>
#mainfig { #mainfig {
background: transparent; background: transparent;
@ -86,7 +86,7 @@ make' root siteName prefix nsfw _dataDir dir
} }
</style> </style>
|] |]
Other col -> [b|@0 Other col -> [b|
<style> #mainfig { background: $col; } </style> <style> #mainfig { background: $col; } </style>
|] |]
@ -104,18 +104,18 @@ make' root siteName prefix nsfw _dataDir dir
let nsfwDialog = NsfwWarning.dialog nsfw' let nsfwDialog = NsfwWarning.dialog nsfw'
let imageMeta = case previewImage info of let imageMeta = case previewImage info of
Just (PFull (Image {path})) -> [b|@0 Just (PFull (Image {path})) -> [b|
<meta property=og:image content="$url/$path"> <meta property=og:image content="$url/$path">
<meta name=twitter:card content=summary_large_image> <meta name=twitter:card content=summary_large_image>
<meta name=twitter:image content="$url/$path"> <meta name=twitter:image content="$url/$path">
|] |]
Just (PThumb path) -> [b|@0 Just (PThumb path) -> [b|
<meta property=og:image content="$url/$path"> <meta property=og:image content="$url/$path">
<meta name=twitter:card content=summary> <meta name=twitter:card content=summary>
|] |]
Nothing -> throw $ NoThumb dir Nothing -> throw $ NoThumb dir
pure [b|@0 pure [b|
<!DOCTYPE html> <!DOCTYPE html>
<html lang=en> <html lang=en>
<meta charset=utf-8> <meta charset=utf-8>
@ -136,7 +136,7 @@ make' root siteName prefix nsfw _dataDir dir
$nsfwScript $nsfwScript
$bgStyle $bgStyle
$0.prefetches $prefetches
<title>$title</title> <title>$title</title>
@ -153,7 +153,7 @@ make' root siteName prefix nsfw _dataDir dir
</h2> </h2>
</header> </header>
$2.buttonBar $buttonBar
<main> <main>
<figure id=mainfig> <figure id=mainfig>
@ -164,15 +164,15 @@ make' root siteName prefix nsfw _dataDir dir
</figure> </figure>
<div id=info> <div id=info>
$6.artistSection $artistSection
$6.descSection $descSection
$6.updatesList $updatesList
$6.linksList $linksList
$6.tagsList $tagsList
</div> </div>
</main> </main>
</div> </div>
@ -187,7 +187,7 @@ last' xs = if null xs then Nothing else Just $ last xs
makeArtist :: Maybe Artist -> Builder makeArtist :: Maybe Artist -> Builder
makeArtist Nothing = "" makeArtist Nothing = ""
makeArtist (Just (Artist {name, url})) = [b|@0 makeArtist (Just (Artist {name, url})) = [b|
<section id=desc class=info-section> <section id=desc class=info-section>
<h2>by</h2> <h2>by</h2>
<div>$artistLink</div> <div>$artistLink</div>
@ -200,25 +200,25 @@ makeArtist (Just (Artist {name, url})) = [b|@0
makeDesc :: Desc -> Builder makeDesc :: Desc -> Builder
makeDesc NoDesc = "" makeDesc NoDesc = ""
makeDesc (TextDesc desc) = [b|@0 makeDesc (TextDesc desc) = [b|
<section id=desc class=info-section> <section id=desc class=info-section>
<h2>about</h2> <h2>about</h2>
<div> <div>
$4.desc $desc
</div> </div>
</section> </section>
|] |]
makeDesc (LongDesc fs) = [b|@0 makeDesc (LongDesc fs) = [b|
<section id=desc class=info-section> <section id=desc class=info-section>
$2.fields $fields
</section> </section>
|] |]
where where
fields = map makeField fs fields = map makeField fs
makeField (DescField {name, text}) = [b|@0 makeField (DescField {name, text}) = [b|
<h2>$name</h2> <h2>$name</h2>
<div> <div>
$4.text $text
</div> </div>
|] |]
@ -262,25 +262,25 @@ makeButtonBar title images =
makeNav "cat" $ fmap (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|
<nav id=alts class=$cls aria-label="alternate versions"> <nav id=alts class=$cls aria-label="alternate versions">
$2.inner $inner
$2.skipAll $skipAll
</nav> |] </nav> |]
makeCat lbl imgs = [b|@0 makeCat lbl imgs = [b|
<section> <section>
<h3 class=alt-cat>$lbl</h3> <h3 class=alt-cat>$lbl</h3>
$0.alts $alts
</section> |] </section> |]
where alts = makeAlts imgs where alts = makeAlts imgs
makeAlts imgs = [b|@0 makeAlts imgs = [b|
<ul class="buttonbar bb-choice"> <ul class="buttonbar bb-choice">
$2.elems $elems
</ul> |] </ul> |]
where elems = fmap (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|
<div class=buttonbar id=skipAllDiv> <div class=buttonbar id=skipAllDiv>
<input type=checkbox name=skipAll id=skipAll> <input type=checkbox name=skipAll id=skipAll>
<label for=skipAll>skip warnings</label> <label for=skipAll>skip warnings</label>
@ -294,7 +294,7 @@ flatten =
fmap (\(t, is) -> fmap (\(i, _) -> i {label = t}) is) 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|
<li$nsfwClass> <li$nsfwClass>
<input type=radio name=variant id="$i" value="$path'" <input type=radio name=variant id="$i" value="$path'"
data-link="$link"$warning'> data-link="$link"$warning'>
@ -310,11 +310,11 @@ altButton img i = [b|@0
makeTags :: FilePath -> [Strict.Text] -> Builder makeTags :: FilePath -> [Strict.Text] -> Builder
makeTags undir tags = makeTags undir tags =
if null tags then "" else [b|@0 if null tags then "" else [b|
<nav id=tags class=info-section> <nav id=tags class=info-section>
<h2>tags</h2> <h2>tags</h2>
<ul> <ul>
$4.tagList $tagList
</ul> </ul>
</nav> </nav>
|] |]
@ -325,18 +325,18 @@ makeTags undir tags =
extLinks :: [Link] -> Builder extLinks :: [Link] -> Builder
extLinks links = extLinks links =
if null links then "" else [b|@0 if null links then "" else [b|
<nav id=links class=info-section> <nav id=links class=info-section>
<h2>links</h2> <h2>links</h2>
<ul> <ul>
$4.linkList $linkList
</ul> </ul>
</nav> </nav>
|] |]
where linkList = map extLink links where linkList = map extLink links
extLink :: Link -> Builder extLink :: Link -> Builder
extLink (Link {title, url}) = [b|@8 extLink (Link {title, url}) = [b|
<li> <li>
<a href="$url"> <a href="$url">
$title $title
@ -345,18 +345,18 @@ extLink (Link {title, url}) = [b|@8
makeUpdates :: [(Date, NonEmpty Update)] -> Builder makeUpdates :: [(Date, NonEmpty Update)] -> Builder
makeUpdates ups = makeUpdates ups =
if all (null . snd) ups then "" else [b|@4 if all (null . snd) ups then "" else [b|
<section id=updates class=info-section> <section id=updates class=info-section>
<h2>updates</h2> <h2>updates</h2>
<dl> <dl>
$8.updateList $updateList
</dl> </dl>
</section> </section>
|] |]
where updateList = fmap (uncurry makeUpdate) ups where updateList = fmap (uncurry makeUpdate) ups
makeUpdate :: Date -> NonEmpty Update -> Builder makeUpdate :: Date -> NonEmpty Update -> Builder
makeUpdate date ups = [b|@8 makeUpdate date ups = [b|
<dt>$date' <dt>$date'
<dd>$desc <dd>$desc
|] where |] where