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

use class instead of twigils for builder

Browse source
This commit is contained in:
Rhiannon Morris 2020-08-30 19:13:40 +02:00
parent e810c3eb08
commit 2adee9ee8e
8 changed files with 140 additions and 155 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

114
make-pages/BuilderQQ.hs
View file

@ -8,12 +8,14 @@ where
import Data.Char (isLower, isSpace, isDigit, isAlphaNum) import Data.Char (isLower, isSpace, isDigit, 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.Maybe (mapMaybe) import Data.Maybe (mapMaybe)
import Data.Text.Lazy.Builder import Data.Text.Lazy.Builder
(Builder, fromText, fromString, singleton, toLazyText) (Builder, fromText, fromLazyText, fromString, singleton, toLazyText)
import Text.Read (readMaybe) import Text.Read (readMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text 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.Foldable
import Data.Semigroup import Data.Semigroup
@ -21,36 +23,31 @@ import Data.Semigroup
data ChunkType = Lit | Var VarType deriving Show data ChunkType = Lit | Var VarType deriving Show
data VarType = data VarType =
Plain Plain
| FromText
| FromString
| FromChar
| Show
| Reindent !Int | Reindent !Int
| ReindentList !Int
deriving Show deriving Show
type Chunk = (ChunkType, Text) type Chunk = (ChunkType, Text)
indent :: Int -> Text -> Builder indent :: Int -> LText.Text -> Builder
indent i str indent i str
| Text.all isSpace str = "" | LText.all isSpace str = ""
| otherwise = replicateB i ' ' <> fromText str | otherwise = replicateB i ' ' <> fromLazyText str
reindent :: Int -> Text -> Builder reindentB :: Int -> Builder -> Builder
reindent i str = reindentB i (toLazyText -> str) =
fold $ mapInit (<> "\n") $ fold $ intersperse "\n" $
map2 (fromText . dropIndent) (indent i . dropIndent) ls map2 (fromLazyText . dropIndent) (indent i . dropIndent) ls
where where
ls = dropWhile (Text.all isSpace) $ Text.lines str ls = dropWhile (LText.all isSpace) $ LText.lines str
ls' = filter (Text.any $ not . isSpace) ls ls' = filter (LText.any $ not . isSpace) ls
dropIndent = Text.drop minIndent dropIndent = LText.drop minIndent
minIndent = minIndent =
getMin $ option 0 id $ foldMap (Option . Just . Min . indentOf) ls' getMin $ option 0 id $ foldMap (Option . Just . Min . indentOf) ls'
indentOf = go 0 where indentOf = go 0 where
go n (' ' :. cs) = go (n + 1) cs go n (' ' :.. cs) = go (n + 1) cs
go n ('\t' :. cs) = go (((n `mod` 8) + 1) * 8) cs go n ('\t' :.. cs) = go (((n `mod` 8) + 1) * 8) cs
go n _ = n go n _ = n
map2 _ _ [] = [] map2 _ _ [] = []
@ -68,38 +65,12 @@ chunks = reverse . go "" [] . trimEnd where
-- $$: expands to one $ -- $$: expands to one $
go acc cs ('$' :. '$' :. rest) = go (acc <> "$") cs rest go acc cs ('$' :. '$' :. rest) = go (acc <> "$") cs rest
-- $*var: expands to (fromText $var) -- $n.var (n a number): expands to builder var indented by n
go acc cs ('$' :. '*' :. rest) =
go "" ((Var FromText, var) : lit acc : cs) rest2
where (var, rest2) = splitVar rest
-- $@var: expands to (fromString $var)
go acc cs ('$' :. '@' :. rest) =
go "" ((Var FromString, var) : lit acc : cs) rest2
where (var, rest2) = splitVar rest
-- $'var: expands to (singleton $var)
go acc cs ('$' :. '\'' :. rest) =
go "" ((Var FromChar, var) : lit acc : cs) rest2
where (var, rest2) = splitVar rest
-- $^var: expands to (fromString (show $var))
go acc cs ('$' :. '^' :. rest) =
go "" ((Var Show, var) : lit acc : cs) rest2
where (var, rest2) = splitVar rest
-- $n*var (n a number): expands to builder var indented by n
-- $n.var: same but var is a list
go acc cs ('$' :. rest@(d :. _)) | isDigit d = go acc cs ('$' :. rest@(d :. _)) | isDigit d =
go "" ((Var ty, var) : lit acc : cs) rest3 go "" ((Var (Reindent n), var) : lit acc : cs) rest3
where where
(n', c :. rest2) = Text.span isDigit rest ((read . Text.unpack -> n), '.' :. rest2) = Text.span isDigit rest
n = read $ Text.unpack n'
(var, rest3) = splitVar rest2 (var, rest3) = splitVar rest2
ty = case c of
'*' -> Reindent n
'.' -> ReindentList n
_ -> error $ "unknown reindent type " ++ show c
-- $var: expands to that var's contents -- $var: expands to that var's contents
go acc cs ('$' :. rest) = go acc cs ('$' :. rest) =
@ -132,35 +103,18 @@ toStrictText = toStrict . toLazyText
chunksToExpQ :: [Chunk] -> ExpQ chunksToExpQ :: [Chunk] -> ExpQ
chunksToExpQ cs = [|mconcat $es|] where chunksToExpQ cs = [|mconcat $es :: Builder|] where
es = listE $ mapMaybe chunk1 cs es = listE $ mapMaybe chunk1 cs
chunk1 (Lit, "") = Nothing chunk1 (Lit, "") = Nothing
chunk1 (Lit, lit) = Just $ stringE $ Text.unpack lit chunk1 (Lit, lit) = Just $ stringE $ Text.unpack lit
chunk1 (Var t, name) = Just $ case t of chunk1 (Var t, name) = Just $ case t of
Plain -> var Plain -> [|build $var|]
FromText -> [|fromText $var|]
FromString -> [|fromString $var|]
FromChar -> [|singleton $var|]
Show -> [|fromString $ show $var|]
Reindent n -> [|reindent n $var|] Reindent n -> [|reindent n $var|]
ReindentList n -> [|reindentList n $var|]
where var = varE (mkName $ Text.unpack name) where var = varE (mkName $ Text.unpack name)
reindentList :: Int -> [Builder] -> Builder
reindentList n = fold . mapInit (<> "\n") . mapTail (replicateB n ' ' <>)
replicateB :: Int -> Char -> Builder replicateB :: Int -> Char -> Builder
replicateB n c = fromText $ Text.replicate n $ Text.singleton c replicateB n c = fromText $ Text.replicate n $ Text.singleton c
mapInit :: (a -> a) -> [a] -> [a]
mapInit _ [] = []
mapInit _ [x] = [x]
mapInit f (x:xs) = f x : mapInit f xs
mapTail :: (a -> a) -> [a] -> [a]
mapTail _ [] = []
mapTail f (x:xs) = x : map f xs
b :: QuasiQuoter b :: QuasiQuoter
b = QuasiQuoter { b = QuasiQuoter {
quoteExp = chunksToExpQ . chunksWithReindent, quoteExp = chunksToExpQ . chunksWithReindent,
@ -181,6 +135,12 @@ pattern c :. t <- (Text.uncons -> Just (c, t))
{-# COMPLETE NilT, (:.) :: Text #-} {-# 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 :: Char -> Builder
fromChar = singleton fromChar = singleton
@ -198,3 +158,25 @@ escId = foldMap esc1 . Text.unpack where
| otherwise = fromChar c | otherwise = fromChar c
latin1Special c = latin1Special c =
c <= 'ÿ' && not (isAlphaNum c) && c /= '-' c <= 'ÿ' && not (isAlphaNum c) && c /= '-'
class CanBuild a where
build :: a -> Builder
reindent :: Int -> a -> Builder
reindent i = reindentB i . build
instance CanBuild Builder where build = id
instance CanBuild Text where build = fromText
instance CanBuild LText.Text where build = fromLazyText
instance CanBuild Char where build = singleton
instance CanBuild String where build = fromString
newtype ShowBuild a = ShowBuild a deriving newtype Show
instance Show a => CanBuild (ShowBuild a) where build = build . show
deriving via ShowBuild Int instance CanBuild Int
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

26
make-pages/Depend.hs
View file

@ -23,7 +23,7 @@ dependSingle yamlDir info prefix build nsfw =
dependSingle' :: FilePath -> Info -> FilePath -> FilePath -> Bool -> Builder dependSingle' :: FilePath -> Info -> FilePath -> FilePath -> Bool -> Builder
dependSingle' yamlDir info prefix build nsfw = dependSingle' yamlDir info prefix build nsfw =
[b|$@page: $@deps $$(MAKEPAGES)|] [b|$page: $deps $$(MAKEPAGES)|]
where where
images = if nsfw then #images info else #sfwImages info images = if nsfw then #images info else #sfwImages info
@ -50,13 +50,13 @@ 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|@0
$@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
@ -80,7 +80,7 @@ dependGallery' (GalleryInfo {prefix, filters})
inc d = tmp </> prefix </> takeDirectory d <.> "mk" inc d = tmp </> prefix </> takeDirectory d <.> "mk"
incFiles = unwords $ map inc files incFiles = unwords $ map inc files
incs = if null infos then "" else [b|include $@incFiles|] incs = if null infos then "" else [b|include $incFiles|]
makeRules :: FilePath -- ^ prefix makeRules :: FilePath -- ^ prefix
-> GalleryFilters -> GalleryFilters
@ -89,16 +89,16 @@ makeRules :: FilePath -- ^ prefix
-> FilePath -- ^ tmp dir -> FilePath -- ^ tmp dir
-> Builder -> Builder
makeRules prefix filters build data_ tmp = [b|@0 makeRules prefix filters build data_ tmp = [b|@0
$@buildPrefix/%/index.html: $@data_/%/info.yaml $$(MAKEPAGES) $buildPrefix/%/index.html: $data_/%/info.yaml $$(MAKEPAGES)
$$(call single,$@data_,$@prefix,$flags) $$(call single,$data_,$prefix,$flags)
$@tmpPrefix/%.mk: $@data_/%/info.yaml $$(MAKEPAGES) $tmpPrefix/%.mk: $data_/%/info.yaml $$(MAKEPAGES)
$$(call depend-single,$@prefix,$@build,$@data_,$flags) $$(call depend-single,$prefix,$build,$data_,$flags)
$@buildPrefix/%: $@tmp/% $buildPrefix/%: $tmp/%
$$(call copy,-l) $$(call copy,-l)
$@buildPrefix/%: $@data_/% $buildPrefix/%: $data_/%
$$(call copy) $$(call copy)
|] |]
where where

36
make-pages/GalleryPage.hs
View file

@ -28,20 +28,20 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
<link rel=alternate href=rss.xml type=application/rss+xml> <link rel=alternate href=rss.xml type=application/rss+xml>
<meta property=og:type content=og:website> <meta property=og:type content=og:website>
<meta property=og:title content="$*title"> <meta property=og:title content="$title">
<meta property=og:site_name content="$*title"> <meta property=og:site_name content="$title">
<meta property=og:description content="$*desc"> <meta property=og:description content="$desc">
<meta property=og:image content="$url/$@imagepath0"> <meta property=og:image content="$url/$imagepath0">
<meta property=og:url content="$url"> <meta property=og:url content="$url">
<meta name=twitter:site content=@gec_ko_> <meta name=twitter:site content=@gec_ko_>
<meta name=twitter:card content=summary> <meta name=twitter:card content=summary>
<script src=/script/gallery.js></script> <script src=/script/gallery.js></script>
<title>$*title</title> <title>$title</title>
<header> <header>
<h1>$*title</h1> <h1>$title</h1>
<h2 class="right corner"> <h2 class="right corner">
<a href=rss.xml>rss</a> <a href=rss.xml>rss</a>
</h2> </h2>
@ -74,7 +74,7 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
</main> </main>
<footer> <footer>
<a href=$@undir>all galleries</a> <a href=$undir>all galleries</a>
</footer> </footer>
|] |]
where where
@ -100,7 +100,7 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
nsfw = #nsfw filters /= NoNsfw nsfw = #nsfw filters /= NoNsfw
url = [b|$*root/$@prefix|] url = [b|$root/$prefix|]
imagepath0 imagepath0
| (_, (p0, i0) : _) : _ <- infosByYear = getThumb (takeDirectory p0) i0 | (_, (p0, i0) : _) : _ <- infosByYear = getThumb (takeDirectory p0) i0
| otherwise = "/style/card.png" | otherwise = "/style/card.png"
@ -108,13 +108,13 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
makeFilter :: Text -> HashSet Text -> Text -> Int -> Builder makeFilter :: Text -> HashSet Text -> Text -> Int -> Builder
makeFilter prefix initial tag _count = [b|@8 makeFilter prefix initial tag _count = [b|@8
<li> <li>
<input type=checkbox id="$id'" value="$*tag"$checked> <input type=checkbox id="$id'" value="$tag"$checked>
<label for="$id'">$*tag</label> <label for="$id'">$tag</label>
|] |]
where where
id' = [b|$*prefix$&_$tag'|] id' = [b|$prefix$&_$tag'|]
tag' = escId tag tag' = escId tag
checked = if HashSet.member tag initial then " checked" else "" checked = if HashSet.member tag initial then [b| checked|] else ""
makeYearItems :: Bool -- ^ nsfw makeYearItems :: Bool -- ^ nsfw
-> Integer -- ^ year -> Integer -- ^ year
@ -127,21 +127,21 @@ makeYearItems nsfw year infos = [b|@4
|] |]
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 {title, bg}) = [b|@4 makeItem nsfw file info@(Info {title, bg}) = [b|@4
<li class="item post$nsfw'" data-tags="$tags'"> <li class="item post$nsfw'" data-tags="$tags'">
<figure> <figure>
<a href="$@dir"> <a href="$dir">
<img src="$@thumb"$bgStyle> <img src="$thumb"$bgStyle>
</a> </a>
<figcaption>$*title</figcaption> <figcaption>$title</figcaption>
</figure> </figure>
|] |]
where where
dir = takeDirectory file dir = takeDirectory file
thumb = getThumb dir info thumb = getThumb dir info
nsfw' = if nsfw && #anyNsfw info then " nsfw" else "" nsfw' = if nsfw && #anyNsfw info then [b| nsfw|] else ""
tags' = fold $ intersperse ";" $ map fromText $ tagsFor nsfw info tags' = fold $ intersperse ";" $ map fromText $ tagsFor nsfw info
bgStyle = ifJust bg \col -> [b| style="background: $*col"|] bgStyle = ifJust bg \col -> [b| style="background: $col"|]

24
make-pages/IndexPage.hs
View file

@ -17,18 +17,18 @@ make' root (IndexInfo {title, desc, galleries, links, footer}) = [b|@0
<link rel=icon href=/style/niss.svg> <link rel=icon href=/style/niss.svg>
<meta property=og:type content=og:website> <meta property=og:type content=og:website>
<meta property=og:title content="$*title"> <meta property=og:title content="$title">
<meta property=og:site_name content="$*title"> <meta property=og:site_name content="$title">
<meta property=og:description content="$*desc"> <meta property=og:description content="$desc">
<meta property=og:image content="$*root/style/card.png"> <meta property=og:image content="$root/style/card.png">
<meta property=og:url content="$url"> <meta property=og:url content="$url">
<meta name=twitter:site content=@gec_ko_> <meta name=twitter:site content=@gec_ko_>
<meta name=twitter:card content=summary> <meta name=twitter:card content=summary>
<title>$*title</title> <title>$title</title>
<header> <header>
<h1 id=title>$*title</h1> <h1 id=title>$title</h1>
</header> </header>
<main> <main>
@ -59,22 +59,22 @@ make' root (IndexInfo {title, desc, galleries, links, footer}) = [b|@0
Nothing -> "" Nothing -> ""
Just f -> [b|@0 Just f -> [b|@0
<footer> <footer>
$2*f $2.f
</footer> </footer>
|] |]
url = [b|$*root|] url = [b|$root|]
makeItem :: GalleryInfo -> Builder makeItem :: GalleryInfo -> Builder
makeItem (GalleryInfo {title, desc, prefix, filters}) = [b|@6 makeItem (GalleryInfo {title, desc, prefix, filters}) = [b|@6
<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 " 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|@6 makeLink (Link {title, url, nsfw}) = [b|@6
<li$nsfw'><a href=$*url>$*title</a> <li$nsfw'><a href=$url>$title</a>
|] |]
where nsfw' = if nsfw then " class=nsfw" else "" where nsfw' = if nsfw then [b| class=nsfw|] else ""
hasNsfw :: GalleryFilters -> Bool hasNsfw :: GalleryFilters -> Bool
hasNsfw (GalleryFilters {nsfw}) = nsfw /= NoNsfw hasNsfw (GalleryFilters {nsfw}) = nsfw /= NoNsfw

3
make-pages/Info.hs
View file

@ -21,6 +21,7 @@ import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Maybe (isJust, isNothing) import Data.Maybe (isJust, isNothing)
import Data.List (nub)
import Data.Ord (comparing) import Data.Ord (comparing)
import Data.String (IsString) import Data.String (IsString)
import Data.Text (Text) import Data.Text (Text)
@ -108,7 +109,7 @@ descFor :: Bool -> Info -> Maybe Text
descFor nsfw (Info {desc, nsfwDesc}) = desc <> (guard nsfw *> nsfwDesc) descFor nsfw (Info {desc, nsfwDesc}) = desc <> (guard nsfw *> nsfwDesc)
tagsFor :: Bool -> Info -> [Text] tagsFor :: Bool -> Info -> [Text]
tagsFor nsfw i = if nsfw then #tags i <> #nsfwTags i else #tags i tagsFor nsfw i = if nsfw then nub (#tags i <> #nsfwTags i) else #tags i
imagesFor :: Bool -> Info -> [Image] imagesFor :: Bool -> Info -> [Image]
imagesFor nsfw = if nsfw then #images else #sfwImages imagesFor nsfw = if nsfw then #images else #sfwImages

18
make-pages/RSS.hs
View file

@ -27,9 +27,9 @@ make' root (GalleryInfo {title, desc, prefix}) output infos = [b|@0
<?xml version="1.0" encoding="UTF-8"?> <?xml version="1.0" encoding="UTF-8"?>
<rss version="2.0" xmlns:atom="http://www.w3.org/2005/Atom"> <rss version="2.0" xmlns:atom="http://www.w3.org/2005/Atom">
<channel> <channel>
<title>$*title</title> <title>$title</title>
<link>$link</link> <link>$link</link>
<description>$*desc</description> <description>$desc</description>
$selflink $selflink
$4.items $4.items
@ -37,16 +37,16 @@ make' root (GalleryInfo {title, desc, prefix}) output infos = [b|@0
</rss> </rss>
|] |]
where where
link = [b|$*root/$@prefix|] link = [b|$root/$prefix|]
items = map (uncurry $ makeItem root prefix) $ sortOn (Down . #second) infos items = map (uncurry $ makeItem root prefix) $ sortOn (Down . #second) infos
selflink = case output of selflink = case output of
Nothing -> "" Nothing -> ""
Just o -> [b|<atom:link href="$link/$@o" rel="self" />|] Just o -> [b|<atom:link href="$link/$o" rel="self" />|]
makeItem :: Strict.Text -> FilePath -> FilePath -> Info -> Builder makeItem :: Strict.Text -> FilePath -> FilePath -> Info -> Builder
makeItem root prefix path (Info {title, desc, date, artist}) = [b|@4 makeItem root prefix path (Info {title, desc, date, artist}) = [b|@4
<item> <item>
<title>$*title</title> <title>$title</title>
<link>$link</link> <link>$link</link>
<guid>$link</guid> <guid>$link</guid>
$descArtist' $descArtist'
@ -55,11 +55,11 @@ makeItem root prefix path (Info {title, desc, date, artist}) = [b|@4
|] |]
where where
dir = takeDirectory path dir = takeDirectory path
link = [b|$*root/$@prefix/$@dir|] link = [b|$root/$prefix/$dir|]
artist' = ifJust artist \case artist' = ifJust artist \case
Artist {name, url = Nothing} -> [b|<p>by $*name|] Artist {name, url = Nothing} -> [b|<p>by $name|]
Artist {name, url = Just url} -> [b|<p>by <a href=$*url>$*name</a>|] Artist {name, url = Just url} -> [b|<p>by <a href=$url>$name</a>|]
desc' = ifJust desc \d -> [b|$10*d|] desc' = ifJust desc \d -> [b|$10.d|]
descArtist' = if isJust desc || isJust artist then [b|@6 descArtist' = if isJust desc || isJust artist then [b|@6
<description> <description>
<![CDATA[ <![CDATA[

71
make-pages/SinglePage.hs
View file

@ -54,22 +54,22 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do
let tagsList = makeTags undir $ tagsFor nsfw info let tagsList = makeTags undir $ tagsFor nsfw info
let linksList = extLinks $ linksFor nsfw info let linksList = extLinks $ linksFor nsfw info
let makePrefetch (Image {path}) = [b|<link rel=prefetch href=$@path>|] let makePrefetch (Image {path}) = [b|<link rel=prefetch href=$path>|]
let prefetches = map (makePrefetch . #first) $ tail images let prefetches = map (makePrefetch . #first) $ tail images
let warning' = ifJust (#warning image0) \w -> [b|@4 let warning' = ifJust (#warning image0) \w -> [b|@4
<figcaption id=cw aria-role=button tabindex=0> <figcaption id=cw aria-role=button tabindex=0>
<span id=cw-text>cw: <b>$*w</b></span> <span id=cw-text>cw: <b>$w</b></span>
</figcaption> </figcaption>
|] |]
let bgStyle = ifJust bg \col -> [b|@0 let bgStyle = ifJust bg \col -> [b|@0
<style> #mainfig { background: $*col; } </style> <style> #mainfig { background: $col; } </style>
|] |]
let url = [b|$*root/$@prefix/$@dir|] let url = [b|$root/$prefix/$dir|]
let desc = case artist of let desc = case artist of
Just (Artist {name}) -> [b|by $*name|] Just (Artist {name}) -> [b|by $name|]
Nothing -> "by niss" Nothing -> "by niss"
let thumb = getThumb "" info let thumb = getThumb "" info
@ -82,10 +82,10 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do
<link rel=icon href=/style/niss.svg> <link rel=icon href=/style/niss.svg>
<meta property=og:type content=og:website> <meta property=og:type content=og:website>
<meta property=og:title content="$*title"> <meta property=og:title content="$title">
<meta property=og:site_name content="$*title"> <meta property=og:site_name content="$title">
<meta property=og:description content="$desc"> <meta property=og:description content="$desc">
<meta property=og:image content="$url/$@thumb"> <meta property=og:image content="$url/$thumb">
<meta property=og:url content="$url"> <meta property=og:url content="$url">
<meta name=twitter:site content=@gec_ko_> <meta name=twitter:site content=@gec_ko_>
<meta name=twitter:card content=summary> <meta name=twitter:card content=summary>
@ -95,10 +95,10 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do
$0.prefetches $0.prefetches
<title>$*title</title> <title>$title</title>
<header> <header>
<h1>$*title</h1> <h1>$title</h1>
$artistTag $artistTag
<h2 id=date class="right corner">$formattedDate</h2> <h2 id=date class="right corner">$formattedDate</h2>
</header> </header>
@ -106,11 +106,10 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do
$buttonBar $buttonBar
<main> <main>
<figure id=mainfig <figure id=mainfig data-width=$width0 data-height=$height0>
data-width=$^width0 data-height=$^height0>
$warning' $warning'
<a id=mainlink href="$@download0" title="download full version"> <a id=mainlink href="$download0" title="download full version">
<img id=mainimg src="$@path0'" alt=""> <img id=mainimg src="$path0'" alt="">
</a> </a>
</figure> </figure>
@ -124,7 +123,7 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do
</main> </main>
<footer> <footer>
<a href=$@undir>back to gallery</a> <a href=$undir>back to gallery</a>
</footer> </footer>
|] |]
@ -133,15 +132,15 @@ makeArtist (Artist {name, url}) =
[b|<h2 id=artist class="left corner">by $artistLink</h2>|] [b|<h2 id=artist class="left corner">by $artistLink</h2>|]
where where
artistLink = case url of artistLink = case url of
Just u -> [b|<a href="$*u">$*name</a>|] Just u -> [b|<a href="$u">$name</a>|]
Nothing -> [b|$*name|] Nothing -> [b|$name|]
makeDesc :: Maybe Strict.Text -> Builder makeDesc :: Maybe Strict.Text -> Builder
makeDesc mdesc = ifJust mdesc \desc -> [b|@4 makeDesc mdesc = ifJust mdesc \desc -> [b|@4
<section id=desc class=info-section> <section id=desc class=info-section>
<h2>about</h2> <h2>about</h2>
<div> <div>
$8*desc $8.desc
</div> </div>
</section> </section>
|] |]
@ -163,18 +162,18 @@ makeButtonBar title images =
altButton :: Int -> Image -> Size -> Builder altButton :: Int -> Image -> Size -> Builder
altButton i (Image {label, path, nsfw, warning}) (Size {width, height}) = [b|@4 altButton i (Image {label, path, nsfw, warning}) (Size {width, height}) = [b|@4
<li$nsfwClass> <li$nsfwClass>
<input type=radio$checked name=variant id="$idLabel" value="$@path'" <input type=radio$checked name=variant id="$idLabel" value="$path'"
data-link="$@path"$warning' data-link="$path"$warning'
data-width=$^width data-height=$^height> data-width=$width data-height=$height>
<label for="$idLabel"$nsfwLabelClass>$*label</label> <label for="$idLabel"$nsfwLabelClass>$label</label>
|] |]
where where
nsfwClass = if nsfw then " class=nsfw" else "" nsfwClass = if nsfw then [b| class=nsfw|] else ""
nsfwLabelClass = if nsfw then " class=nsfw-label" else "" nsfwLabelClass = if nsfw then [b| class=nsfw-label|] else ""
checked = if i == 0 then " checked" else "" checked = if i == 0 then [b| checked|] else ""
idLabel = escId label idLabel = escId label
path' = pageFile path path' = pageFile path
warning' = ifJust warning \w -> [b| data-warning="$*w"|] warning' = ifJust warning \w -> [b| data-warning="$w"|]
makeTags :: FilePath -> [Strict.Text] -> Builder makeTags :: FilePath -> [Strict.Text] -> Builder
makeTags undir tags = makeTags undir tags =
@ -188,7 +187,7 @@ makeTags undir tags =
|] |]
where where
tagList = map makeTag tags tagList = map makeTag tags
makeTag tag = [b|<li><a href="$@undir#require_$tag'">$*tag</a>|] makeTag tag = [b|<li><a href="$undir#require_$tag'">$tag</a>|]
where tag' = escId tag where tag' = escId tag
extLinks :: [Link] -> Builder extLinks :: [Link] -> Builder
@ -206,13 +205,13 @@ extLinks links =
extLink :: Link -> Builder extLink :: Link -> Builder
extLink (Link {title, url}) = [b|@8 extLink (Link {title, url}) = [b|@8
<li> <li>
<a href="$*url"> <a href="$url">
$*title $title
</a> </a>
|] |]
formatDate :: Day -> Builder formatDate :: Day -> Builder
formatDate date = [b|$*week $day $*month $^year|] where formatDate date = [b|$week $day $month $year|] where
(year, month', day') = Time.toGregorian date (year, month', day') = Time.toGregorian date
week' = Time.dayOfWeek date week' = Time.dayOfWeek date
day = nth day' day = nth day'
@ -222,12 +221,12 @@ formatDate date = [b|$*week $day $*month $^year|] where
week = Strict.words "mon tue wed thu fri sat sun" !! (fromEnum week' - 1) week = Strict.words "mon tue wed thu fri sat sun" !! (fromEnum week' - 1)
nth :: Int -> Builder nth :: Int -> Builder
nth n = [b|$^n$suf|] where nth n = [b|$n$suf|] where
suf | n >= 10, n <= 19 = "th" suf | n >= 10, n <= 19 = [b|th|]
| n `mod` 10 == 1 = "st" | n `mod` 10 == 1 = [b|st|]
| n `mod` 10 == 2 = "nd" | n `mod` 10 == 2 = [b|nd|]
| n `mod` 10 == 3 = "rd" | n `mod` 10 == 3 = [b|rd|]
| otherwise = "th" | otherwise = [b|th|]
data Size = Size {width, height :: !Int} deriving (Eq, Show) data Size = Size {width, height :: !Int} deriving (Eq, Show)

3
make-pages/make-pages.cabal
View file

@ -31,8 +31,10 @@ executable make-pages
DataKinds, DataKinds,
DeriveAnyClass, DeriveAnyClass,
DerivingStrategies, DerivingStrategies,
DerivingVia,
DuplicateRecordFields, DuplicateRecordFields,
FlexibleInstances, FlexibleInstances,
GeneralizedNewtypeDeriving,
LambdaCase, LambdaCase,
NamedFieldPuns, NamedFieldPuns,
OverloadedLabels, OverloadedLabels,
@ -41,6 +43,7 @@ executable make-pages
PatternSynonyms, PatternSynonyms,
QuasiQuotes, QuasiQuotes,
RankNTypes, RankNTypes,
StandaloneDeriving,
TupleSections, TupleSections,
TypeSynonymInstances, TypeSynonymInstances,
ViewPatterns ViewPatterns