use class instead of twigils for builder
This commit is contained in:
parent
e810c3eb08
commit
2adee9ee8e
8 changed files with 140 additions and 155 deletions
|
|
@ -8,12 +8,14 @@ where
|
|||
import Data.Char (isLower, isSpace, isDigit, isAlphaNum)
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Quote
|
||||
import Data.List (intersperse)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Text.Lazy.Builder
|
||||
(Builder, fromText, fromString, singleton, toLazyText)
|
||||
(Builder, fromText, fromLazyText, fromString, singleton, toLazyText)
|
||||
import Text.Read (readMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lazy as LText
|
||||
import Data.Text.Lazy (toStrict)
|
||||
import Data.Foldable
|
||||
import Data.Semigroup
|
||||
|
|
@ -21,36 +23,31 @@ import Data.Semigroup
|
|||
data ChunkType = Lit | Var VarType deriving Show
|
||||
data VarType =
|
||||
Plain
|
||||
| FromText
|
||||
| FromString
|
||||
| FromChar
|
||||
| Show
|
||||
| Reindent !Int
|
||||
| ReindentList !Int
|
||||
deriving Show
|
||||
type Chunk = (ChunkType, Text)
|
||||
|
||||
indent :: Int -> Text -> Builder
|
||||
indent :: Int -> LText.Text -> Builder
|
||||
indent i str
|
||||
| Text.all isSpace str = ""
|
||||
| otherwise = replicateB i ' ' <> fromText str
|
||||
| LText.all isSpace str = ""
|
||||
| otherwise = replicateB i ' ' <> fromLazyText str
|
||||
|
||||
reindent :: Int -> Text -> Builder
|
||||
reindent i str =
|
||||
fold $ mapInit (<> "\n") $
|
||||
map2 (fromText . dropIndent) (indent i . dropIndent) ls
|
||||
reindentB :: Int -> Builder -> Builder
|
||||
reindentB i (toLazyText -> str) =
|
||||
fold $ intersperse "\n" $
|
||||
map2 (fromLazyText . dropIndent) (indent i . dropIndent) ls
|
||||
where
|
||||
ls = dropWhile (Text.all isSpace) $ Text.lines str
|
||||
ls' = filter (Text.any $ not . isSpace) ls
|
||||
ls = dropWhile (LText.all isSpace) $ LText.lines str
|
||||
ls' = filter (LText.any $ not . isSpace) ls
|
||||
|
||||
dropIndent = Text.drop minIndent
|
||||
dropIndent = LText.drop minIndent
|
||||
|
||||
minIndent =
|
||||
getMin $ option 0 id $ foldMap (Option . 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 (' ' :.. cs) = go (n + 1) cs
|
||||
go n ('\t' :.. cs) = go (((n `mod` 8) + 1) * 8) cs
|
||||
go n _ = n
|
||||
|
||||
map2 _ _ [] = []
|
||||
|
|
@ -68,38 +65,12 @@ chunks = reverse . go "" [] . trimEnd where
|
|||
-- $$: expands to one $
|
||||
go acc cs ('$' :. '$' :. rest) = go (acc <> "$") cs rest
|
||||
|
||||
-- $*var: expands to (fromText $var)
|
||||
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
|
||||
-- $n.var (n a number): expands to builder var indented by n
|
||||
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
|
||||
(n', c :. rest2) = Text.span isDigit rest
|
||||
n = read $ Text.unpack n'
|
||||
((read . Text.unpack -> n), '.' :. rest2) = Text.span isDigit rest
|
||||
(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
|
||||
go acc cs ('$' :. rest) =
|
||||
|
|
@ -132,35 +103,18 @@ toStrictText = toStrict . toLazyText
|
|||
|
||||
|
||||
chunksToExpQ :: [Chunk] -> ExpQ
|
||||
chunksToExpQ cs = [|mconcat $es|] where
|
||||
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 -> var
|
||||
FromText -> [|fromText $var|]
|
||||
FromString -> [|fromString $var|]
|
||||
FromChar -> [|singleton $var|]
|
||||
Show -> [|fromString $ show $var|]
|
||||
Plain -> [|build $var|]
|
||||
Reindent n -> [|reindent n $var|]
|
||||
ReindentList n -> [|reindentList n $var|]
|
||||
where var = varE (mkName $ Text.unpack name)
|
||||
|
||||
reindentList :: Int -> [Builder] -> Builder
|
||||
reindentList n = fold . mapInit (<> "\n") . mapTail (replicateB n ' ' <>)
|
||||
|
||||
replicateB :: Int -> Char -> Builder
|
||||
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 {
|
||||
quoteExp = chunksToExpQ . chunksWithReindent,
|
||||
|
|
@ -181,6 +135,12 @@ pattern c :. t <- (Text.uncons -> Just (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
|
||||
|
||||
|
|
@ -198,3 +158,25 @@ escId = foldMap esc1 . Text.unpack where
|
|||
| otherwise = fromChar c
|
||||
latin1Special 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
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@ dependSingle yamlDir info prefix build nsfw =
|
|||
|
||||
dependSingle' :: FilePath -> Info -> FilePath -> FilePath -> Bool -> Builder
|
||||
dependSingle' yamlDir info prefix build nsfw =
|
||||
[b|$@page: $@deps $$(MAKEPAGES)|]
|
||||
[b|$page: $deps $$(MAKEPAGES)|]
|
||||
where
|
||||
images = if nsfw then #images info else #sfwImages info
|
||||
|
||||
|
|
@ -50,13 +50,13 @@ dependGallery' :: GalleryInfo -> FilePath -> [(FilePath, Info)]
|
|||
-> FilePath -> FilePath -> FilePath -> Builder
|
||||
dependGallery' (GalleryInfo {prefix, filters})
|
||||
indexFile infos' build data_ tmp = [b|@0
|
||||
$@index: $@gallery
|
||||
$index: $gallery
|
||||
|
||||
$@gallery: $@pages' $@files' $@rss $@indexFile $$(MAKEPAGES)
|
||||
$$(call gallery,$@indexFile,$@prefix)
|
||||
$gallery: $pages' $files' $rss $indexFile $$(MAKEPAGES)
|
||||
$$(call gallery,$indexFile,$prefix)
|
||||
|
||||
$@rss: $@files' $@indexFile $$(MAKEPAGES)
|
||||
$$(call rss,$@indexFile,$@prefix,$@data_)
|
||||
$rss: $files' $indexFile $$(MAKEPAGES)
|
||||
$$(call rss,$indexFile,$prefix,$data_)
|
||||
|
||||
$rules
|
||||
|
||||
|
|
@ -80,7 +80,7 @@ dependGallery' (GalleryInfo {prefix, filters})
|
|||
|
||||
inc d = tmp </> prefix </> takeDirectory d <.> "mk"
|
||||
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
|
||||
-> GalleryFilters
|
||||
|
|
@ -89,16 +89,16 @@ makeRules :: FilePath -- ^ prefix
|
|||
-> FilePath -- ^ tmp dir
|
||||
-> Builder
|
||||
makeRules prefix filters build data_ tmp = [b|@0
|
||||
$@buildPrefix/%/index.html: $@data_/%/info.yaml $$(MAKEPAGES)
|
||||
$$(call single,$@data_,$@prefix,$flags)
|
||||
$buildPrefix/%/index.html: $data_/%/info.yaml $$(MAKEPAGES)
|
||||
$$(call single,$data_,$prefix,$flags)
|
||||
|
||||
$@tmpPrefix/%.mk: $@data_/%/info.yaml $$(MAKEPAGES)
|
||||
$$(call depend-single,$@prefix,$@build,$@data_,$flags)
|
||||
$tmpPrefix/%.mk: $data_/%/info.yaml $$(MAKEPAGES)
|
||||
$$(call depend-single,$prefix,$build,$data_,$flags)
|
||||
|
||||
$@buildPrefix/%: $@tmp/%
|
||||
$buildPrefix/%: $tmp/%
|
||||
$$(call copy,-l)
|
||||
|
||||
$@buildPrefix/%: $@data_/%
|
||||
$buildPrefix/%: $data_/%
|
||||
$$(call copy)
|
||||
|]
|
||||
where
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
<meta property=og:type content=og:website>
|
||||
<meta property=og:title content="$*title">
|
||||
<meta property=og:site_name content="$*title">
|
||||
<meta property=og:description content="$*desc">
|
||||
<meta property=og:image content="$url/$@imagepath0">
|
||||
<meta property=og:title content="$title">
|
||||
<meta property=og:site_name content="$title">
|
||||
<meta property=og:description content="$desc">
|
||||
<meta property=og:image content="$url/$imagepath0">
|
||||
<meta property=og:url content="$url">
|
||||
<meta name=twitter:site content=@gec_ko_>
|
||||
<meta name=twitter:card content=summary>
|
||||
|
||||
<script src=/script/gallery.js></script>
|
||||
|
||||
<title>$*title</title>
|
||||
<title>$title</title>
|
||||
|
||||
<header>
|
||||
<h1>$*title</h1>
|
||||
<h1>$title</h1>
|
||||
<h2 class="right corner">
|
||||
<a href=rss.xml>rss</a>
|
||||
</h2>
|
||||
|
|
@ -74,7 +74,7 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
|
|||
</main>
|
||||
|
||||
<footer>
|
||||
<a href=$@undir>all galleries</a>
|
||||
<a href=$undir>all galleries</a>
|
||||
</footer>
|
||||
|]
|
||||
where
|
||||
|
|
@ -100,7 +100,7 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
|
|||
|
||||
nsfw = #nsfw filters /= NoNsfw
|
||||
|
||||
url = [b|$*root/$@prefix|]
|
||||
url = [b|$root/$prefix|]
|
||||
imagepath0
|
||||
| (_, (p0, i0) : _) : _ <- infosByYear = getThumb (takeDirectory p0) i0
|
||||
| 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 prefix initial tag _count = [b|@8
|
||||
<li>
|
||||
<input type=checkbox id="$id'" value="$*tag"$checked>
|
||||
<label for="$id'">$*tag</label>
|
||||
<input type=checkbox id="$id'" value="$tag"$checked>
|
||||
<label for="$id'">$tag</label>
|
||||
|]
|
||||
where
|
||||
id' = [b|$*prefix$&_$tag'|]
|
||||
id' = [b|$prefix$&_$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
|
||||
-> Integer -- ^ year
|
||||
|
|
@ -127,21 +127,21 @@ makeYearItems nsfw year infos = [b|@4
|
|||
|]
|
||||
where
|
||||
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 nsfw file info@(Info {title, bg}) = [b|@4
|
||||
<li class="item post$nsfw'" data-tags="$tags'">
|
||||
<figure>
|
||||
<a href="$@dir">
|
||||
<img src="$@thumb"$bgStyle>
|
||||
<a href="$dir">
|
||||
<img src="$thumb"$bgStyle>
|
||||
</a>
|
||||
<figcaption>$*title</figcaption>
|
||||
<figcaption>$title</figcaption>
|
||||
</figure>
|
||||
|]
|
||||
where
|
||||
dir = takeDirectory file
|
||||
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
|
||||
bgStyle = ifJust bg \col -> [b| style="background: $*col"|]
|
||||
bgStyle = ifJust bg \col -> [b| style="background: $col"|]
|
||||
|
|
|
|||
|
|
@ -17,18 +17,18 @@ make' root (IndexInfo {title, desc, galleries, links, footer}) = [b|@0
|
|||
<link rel=icon href=/style/niss.svg>
|
||||
|
||||
<meta property=og:type content=og:website>
|
||||
<meta property=og:title content="$*title">
|
||||
<meta property=og:site_name content="$*title">
|
||||
<meta property=og:description content="$*desc">
|
||||
<meta property=og:image content="$*root/style/card.png">
|
||||
<meta property=og:title content="$title">
|
||||
<meta property=og:site_name content="$title">
|
||||
<meta property=og:description content="$desc">
|
||||
<meta property=og:image content="$root/style/card.png">
|
||||
<meta property=og:url content="$url">
|
||||
<meta name=twitter:site content=@gec_ko_>
|
||||
<meta name=twitter:card content=summary>
|
||||
|
||||
<title>$*title</title>
|
||||
<title>$title</title>
|
||||
|
||||
<header>
|
||||
<h1 id=title>$*title</h1>
|
||||
<h1 id=title>$title</h1>
|
||||
</header>
|
||||
|
||||
<main>
|
||||
|
|
@ -59,22 +59,22 @@ make' root (IndexInfo {title, desc, galleries, links, footer}) = [b|@0
|
|||
Nothing -> ""
|
||||
Just f -> [b|@0
|
||||
<footer>
|
||||
$2*f
|
||||
$2.f
|
||||
</footer>
|
||||
|]
|
||||
url = [b|$*root|]
|
||||
url = [b|$root|]
|
||||
|
||||
makeItem :: GalleryInfo -> Builder
|
||||
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 {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 {nsfw}) = nsfw /= NoNsfw
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ import Data.HashSet (HashSet)
|
|||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (isJust, isNothing)
|
||||
import Data.List (nub)
|
||||
import Data.Ord (comparing)
|
||||
import Data.String (IsString)
|
||||
import Data.Text (Text)
|
||||
|
|
@ -108,7 +109,7 @@ descFor :: Bool -> Info -> Maybe Text
|
|||
descFor nsfw (Info {desc, nsfwDesc}) = desc <> (guard nsfw *> nsfwDesc)
|
||||
|
||||
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 nsfw = if nsfw then #images else #sfwImages
|
||||
|
|
|
|||
|
|
@ -27,9 +27,9 @@ make' root (GalleryInfo {title, desc, prefix}) output infos = [b|@0
|
|||
<?xml version="1.0" encoding="UTF-8"?>
|
||||
<rss version="2.0" xmlns:atom="http://www.w3.org/2005/Atom">
|
||||
<channel>
|
||||
<title>$*title</title>
|
||||
<title>$title</title>
|
||||
<link>$link</link>
|
||||
<description>$*desc</description>
|
||||
<description>$desc</description>
|
||||
$selflink
|
||||
|
||||
$4.items
|
||||
|
|
@ -37,16 +37,16 @@ make' root (GalleryInfo {title, desc, prefix}) output infos = [b|@0
|
|||
</rss>
|
||||
|]
|
||||
where
|
||||
link = [b|$*root/$@prefix|]
|
||||
link = [b|$root/$prefix|]
|
||||
items = map (uncurry $ makeItem root prefix) $ sortOn (Down . #second) infos
|
||||
selflink = case output of
|
||||
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 root prefix path (Info {title, desc, date, artist}) = [b|@4
|
||||
<item>
|
||||
<title>$*title</title>
|
||||
<title>$title</title>
|
||||
<link>$link</link>
|
||||
<guid>$link</guid>
|
||||
$descArtist'
|
||||
|
|
@ -55,11 +55,11 @@ makeItem root prefix path (Info {title, desc, date, artist}) = [b|@4
|
|||
|]
|
||||
where
|
||||
dir = takeDirectory path
|
||||
link = [b|$*root/$@prefix/$@dir|]
|
||||
link = [b|$root/$prefix/$dir|]
|
||||
artist' = ifJust artist \case
|
||||
Artist {name, url = Nothing} -> [b|<p>by $*name|]
|
||||
Artist {name, url = Just url} -> [b|<p>by <a href=$*url>$*name</a>|]
|
||||
desc' = ifJust desc \d -> [b|$10*d|]
|
||||
Artist {name, url = Nothing} -> [b|<p>by $name|]
|
||||
Artist {name, url = Just url} -> [b|<p>by <a href=$url>$name</a>|]
|
||||
desc' = ifJust desc \d -> [b|$10.d|]
|
||||
descArtist' = if isJust desc || isJust artist then [b|@6
|
||||
<description>
|
||||
<![CDATA[
|
||||
|
|
|
|||
|
|
@ -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 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 warning' = ifJust (#warning image0) \w -> [b|@4
|
||||
<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>
|
||||
|]
|
||||
|
||||
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
|
||||
Just (Artist {name}) -> [b|by $*name|]
|
||||
Just (Artist {name}) -> [b|by $name|]
|
||||
Nothing -> "by niss"
|
||||
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>
|
||||
|
||||
<meta property=og:type content=og:website>
|
||||
<meta property=og:title content="$*title">
|
||||
<meta property=og:site_name content="$*title">
|
||||
<meta property=og:title content="$title">
|
||||
<meta property=og:site_name content="$title">
|
||||
<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 name=twitter:site content=@gec_ko_>
|
||||
<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
|
||||
|
||||
<title>$*title</title>
|
||||
<title>$title</title>
|
||||
|
||||
<header>
|
||||
<h1>$*title</h1>
|
||||
<h1>$title</h1>
|
||||
$artistTag
|
||||
<h2 id=date class="right corner">$formattedDate</h2>
|
||||
</header>
|
||||
|
|
@ -106,11 +106,10 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do
|
|||
$buttonBar
|
||||
|
||||
<main>
|
||||
<figure id=mainfig
|
||||
data-width=$^width0 data-height=$^height0>
|
||||
<figure id=mainfig data-width=$width0 data-height=$height0>
|
||||
$warning'
|
||||
<a id=mainlink href="$@download0" title="download full version">
|
||||
<img id=mainimg src="$@path0'" alt="">
|
||||
<a id=mainlink href="$download0" title="download full version">
|
||||
<img id=mainimg src="$path0'" alt="">
|
||||
</a>
|
||||
</figure>
|
||||
|
||||
|
|
@ -124,7 +123,7 @@ make' root prefix nsfw dataDir dir info@(Info {date, title, artist, bg}) = do
|
|||
</main>
|
||||
|
||||
<footer>
|
||||
<a href=$@undir>back to gallery</a>
|
||||
<a href=$undir>back to gallery</a>
|
||||
</footer>
|
||||
|]
|
||||
|
||||
|
|
@ -133,15 +132,15 @@ makeArtist (Artist {name, url}) =
|
|||
[b|<h2 id=artist class="left corner">by $artistLink</h2>|]
|
||||
where
|
||||
artistLink = case url of
|
||||
Just u -> [b|<a href="$*u">$*name</a>|]
|
||||
Nothing -> [b|$*name|]
|
||||
Just u -> [b|<a href="$u">$name</a>|]
|
||||
Nothing -> [b|$name|]
|
||||
|
||||
makeDesc :: Maybe Strict.Text -> Builder
|
||||
makeDesc mdesc = ifJust mdesc \desc -> [b|@4
|
||||
<section id=desc class=info-section>
|
||||
<h2>about</h2>
|
||||
<div>
|
||||
$8*desc
|
||||
$8.desc
|
||||
</div>
|
||||
</section>
|
||||
|]
|
||||
|
|
@ -163,18 +162,18 @@ makeButtonBar title images =
|
|||
altButton :: Int -> Image -> Size -> Builder
|
||||
altButton i (Image {label, path, nsfw, warning}) (Size {width, height}) = [b|@4
|
||||
<li$nsfwClass>
|
||||
<input type=radio$checked name=variant id="$idLabel" value="$@path'"
|
||||
data-link="$@path"$warning'
|
||||
data-width=$^width data-height=$^height>
|
||||
<label for="$idLabel"$nsfwLabelClass>$*label</label>
|
||||
<input type=radio$checked name=variant id="$idLabel" value="$path'"
|
||||
data-link="$path"$warning'
|
||||
data-width=$width data-height=$height>
|
||||
<label for="$idLabel"$nsfwLabelClass>$label</label>
|
||||
|]
|
||||
where
|
||||
nsfwClass = if nsfw then " class=nsfw" else ""
|
||||
nsfwLabelClass = if nsfw then " class=nsfw-label" else ""
|
||||
checked = if i == 0 then " checked" else ""
|
||||
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
|
||||
warning' = ifJust warning \w -> [b| data-warning="$*w"|]
|
||||
warning' = ifJust warning \w -> [b| data-warning="$w"|]
|
||||
|
||||
makeTags :: FilePath -> [Strict.Text] -> Builder
|
||||
makeTags undir tags =
|
||||
|
|
@ -188,7 +187,7 @@ makeTags undir tags =
|
|||
|]
|
||||
where
|
||||
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
|
||||
|
||||
extLinks :: [Link] -> Builder
|
||||
|
|
@ -206,13 +205,13 @@ extLinks links =
|
|||
extLink :: Link -> Builder
|
||||
extLink (Link {title, url}) = [b|@8
|
||||
<li>
|
||||
<a href="$*url">
|
||||
$*title
|
||||
<a href="$url">
|
||||
$title
|
||||
</a>
|
||||
|]
|
||||
|
||||
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
|
||||
week' = Time.dayOfWeek date
|
||||
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)
|
||||
|
||||
nth :: Int -> Builder
|
||||
nth n = [b|$^n$suf|] where
|
||||
suf | n >= 10, n <= 19 = "th"
|
||||
| n `mod` 10 == 1 = "st"
|
||||
| n `mod` 10 == 2 = "nd"
|
||||
| n `mod` 10 == 3 = "rd"
|
||||
| otherwise = "th"
|
||||
nth n = [b|$n$suf|] where
|
||||
suf | n >= 10, n <= 19 = [b|th|]
|
||||
| n `mod` 10 == 1 = [b|st|]
|
||||
| n `mod` 10 == 2 = [b|nd|]
|
||||
| n `mod` 10 == 3 = [b|rd|]
|
||||
| otherwise = [b|th|]
|
||||
|
||||
|
||||
data Size = Size {width, height :: !Int} deriving (Eq, Show)
|
||||
|
|
|
|||
|
|
@ -31,8 +31,10 @@ executable make-pages
|
|||
DataKinds,
|
||||
DeriveAnyClass,
|
||||
DerivingStrategies,
|
||||
DerivingVia,
|
||||
DuplicateRecordFields,
|
||||
FlexibleInstances,
|
||||
GeneralizedNewtypeDeriving,
|
||||
LambdaCase,
|
||||
NamedFieldPuns,
|
||||
OverloadedLabels,
|
||||
|
|
@ -41,6 +43,7 @@ executable make-pages
|
|||
PatternSynonyms,
|
||||
QuasiQuotes,
|
||||
RankNTypes,
|
||||
StandaloneDeriving,
|
||||
TupleSections,
|
||||
TypeSynonymInstances,
|
||||
ViewPatterns
|
||||
|
|
|
|||
Loading…
Reference in a new issue