remove the reindent stuff. it does not matter
This commit is contained in:
parent
47d0d6a2cb
commit
7745722009
7 changed files with 123 additions and 238 deletions
|
@ -1,184 +1,72 @@
|
|||
{-# LANGUAGE PatternSynonyms, TemplateHaskell #-}
|
||||
module BuilderQQ
|
||||
(b,
|
||||
Builder, toStrictText, toLazyText, fromText, fromString, fromChar,
|
||||
textMap, ifJust, escId, escAttr, CanBuild (..))
|
||||
(b, Builder, toStrictText, toLazyText, fromText, fromString,
|
||||
ifJust, escId, escAttr, CanBuild (..))
|
||||
where
|
||||
|
||||
import Data.Char (isLower, isSpace, isDigit, isAlphaNum)
|
||||
import Data.Char (isSpace, isAlphaNum)
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Quote
|
||||
import Data.List (intersperse)
|
||||
import Data.List (dropWhileEnd)
|
||||
import Data.Maybe (mapMaybe, fromMaybe)
|
||||
import Data.Text.Lazy.Builder
|
||||
(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 qualified Data.Text as Strict
|
||||
import qualified Data.Text.Lazy as Lazy
|
||||
import Data.Text.Lazy (toStrict)
|
||||
import Data.Foldable
|
||||
import Data.Semigroup
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.List.NonEmpty (NonEmpty, toList)
|
||||
|
||||
data ChunkType = Lit | Var VarType deriving Show
|
||||
data VarType =
|
||||
Plain
|
||||
| Reindent !Int
|
||||
deriving Show
|
||||
type Chunk = (ChunkType, Text)
|
||||
data Chunk = Lit String | Var String
|
||||
|
||||
indent :: Int -> LText.Text -> Builder
|
||||
indent i str
|
||||
| LText.all isSpace str = ""
|
||||
| otherwise = replicateB i ' ' <> fromLazyText str
|
||||
parseB :: String -> ExpQ
|
||||
parseB = toExpQ . reverse . go "" [] . dropWhileEnd isSpace where
|
||||
go acc cs [] = addLit acc cs
|
||||
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
|
||||
reindentB i (toLazyText -> str) =
|
||||
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
|
||||
addLit l cs = if null l then cs else Lit (reverse l) : cs
|
||||
isIdChar c = isAlphaNum c || c `elem` ("_'" :: String)
|
||||
|
||||
dropIndent = LText.drop minIndent
|
||||
|
||||
minIndent =
|
||||
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
|
||||
toExpQ cs = [|mconcat $(listE $ mapMaybe chunk1 cs) :: Builder|]
|
||||
chunk1 (Lit lit) = Just $ stringE lit
|
||||
chunk1 (Var name) = Just $ [|build $(varE $ mkName name)|]
|
||||
|
||||
|
||||
chunks :: Text -> [Chunk]
|
||||
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 :: Builder -> Strict.Text
|
||||
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 {
|
||||
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"
|
||||
}
|
||||
b = QuasiQuoter parseB undefined undefined undefined
|
||||
|
||||
|
||||
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 x f = maybe mempty f x
|
||||
|
||||
|
||||
escId :: Text -> Builder
|
||||
escId = foldMap esc1 . Text.unpack where
|
||||
escId :: Strict.Text -> Builder
|
||||
escId = foldMap esc1 . Strict.unpack where
|
||||
esc1 c | isSpace c = ""
|
||||
| latin1Special c = "_"
|
||||
| otherwise = fromChar c
|
||||
| otherwise = singleton c
|
||||
latin1Special c =
|
||||
c <= 'ÿ' && not (isAlphaNum c) && c /= '-'
|
||||
|
||||
escAttr :: Text -> Builder
|
||||
escAttr = foldMap esc1 . Text.unpack where
|
||||
esc1 '<' = "<"
|
||||
esc1 '>' = ">"
|
||||
esc1 '"' = """
|
||||
esc1 '\'' = "'"
|
||||
esc1 c = fromChar c
|
||||
escAttr :: Strict.Text -> Builder
|
||||
escAttr = foldMap esc1 . Strict.unpack where
|
||||
esc1 c = fromMaybe (singleton c) $ lookup c
|
||||
[('<', "<"), ('>', ">"), ('"', """), ('\'', "'")]
|
||||
|
||||
|
||||
class CanBuild a where
|
||||
build :: a -> Builder
|
||||
reindent :: Int -> a -> Builder
|
||||
reindent i = reindentB i . build
|
||||
class CanBuild a where build :: a -> Builder
|
||||
|
||||
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
|
||||
instance CanBuild Builder where build = id
|
||||
instance CanBuild Strict.Text where build = fromText
|
||||
instance CanBuild Lazy.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
|
||||
|
@ -188,8 +76,5 @@ 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
|
||||
|
||||
instance CanBuild a => CanBuild (NonEmpty a) where
|
||||
build = build . toList
|
||||
reindent n = reindent n . toList
|
||||
instance CanBuild a => CanBuild (NonEmpty a) where build = build . toList
|
||||
|
|
|
@ -56,19 +56,19 @@ dependGallery ginfo index infos build data_ tmp =
|
|||
dependGallery' :: GalleryInfo -> FilePath -> [(FilePath, Info)]
|
||||
-> FilePath -> FilePath -> FilePath -> Builder
|
||||
dependGallery' (GalleryInfo {prefix, filters})
|
||||
indexFile infos' build data_ tmp = [b|@0
|
||||
$index: $gallery
|
||||
indexFile infos' build data_ tmp = [b|
|
||||
$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
|
||||
$rules
|
||||
|
||||
$incs
|
||||
|]
|
||||
$incs
|
||||
|]
|
||||
where
|
||||
infos = filter (matchFilters filters . snd) infos'
|
||||
|
||||
|
@ -96,19 +96,19 @@ makeRules :: FilePath -- ^ prefix
|
|||
-> FilePath -- ^ data dir
|
||||
-> FilePath -- ^ tmp dir
|
||||
-> Builder
|
||||
makeRules prefix indexFile filters build data_ tmp = [b|@0
|
||||
$buildPrefix/%/index.html: $data_/%/info.yaml $$(MAKEPAGES)
|
||||
$$(call single,$data_,$prefix,$indexFile,$flags)
|
||||
makeRules prefix indexFile filters build data_ tmp = [b|
|
||||
$buildPrefix/%/index.html: $data_/%/info.yaml $$(MAKEPAGES)
|
||||
$$(call single,$data_,$prefix,$indexFile,$flags)
|
||||
|
||||
$tmpPrefix/%.mk: $data_/%/info.yaml $$(MAKEPAGES)
|
||||
$$(call depend-single,$prefix,$indexFile,$build,$data_,$flags)
|
||||
$tmpPrefix/%.mk: $data_/%/info.yaml $$(MAKEPAGES)
|
||||
$$(call depend-single,$prefix,$indexFile,$build,$data_,$flags)
|
||||
|
||||
$buildPrefix/%: $tmp/%
|
||||
$$(call copy,-l)
|
||||
$buildPrefix/%: $tmp/%
|
||||
$$(call copy,-l)
|
||||
|
||||
$buildPrefix/%: $data_/%
|
||||
$$(call copy)
|
||||
|]
|
||||
$buildPrefix/%: $data_/%
|
||||
$$(call copy)
|
||||
|]
|
||||
where
|
||||
buildPrefix = build </> prefix
|
||||
tmpPrefix = tmp </> prefix
|
||||
|
|
|
@ -22,7 +22,7 @@ make root ginfo infos = toLazyText $ make' root ginfo infos
|
|||
|
||||
|
||||
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>
|
||||
<html lang=en>
|
||||
<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'>
|
||||
|
||||
<script src=/script/gallery.js type=module></script>
|
||||
$0.nsfwScript
|
||||
$nsfwScript
|
||||
|
||||
<title>$title</title>
|
||||
|
||||
$0.nsfwDialog
|
||||
$nsfwDialog
|
||||
|
||||
<div class=page>
|
||||
<header>
|
||||
|
@ -61,12 +61,12 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
|
|||
<div>
|
||||
<h3>show only</h3>
|
||||
<ul id=require class=filterlist>
|
||||
$10.requireFilters
|
||||
$requireFilters
|
||||
</ul>
|
||||
|
||||
<h3>exclude</h3>
|
||||
<ul id=exclude class=filterlist>
|
||||
$10.excludeFilters
|
||||
$excludeFilters
|
||||
</ul>
|
||||
|
||||
<ul id=filterstuff>
|
||||
|
@ -81,7 +81,7 @@ make' root (GalleryInfo {title, desc, prefix, filters, hidden}) infos = [b|@0
|
|||
|
||||
<main>
|
||||
<ul class=grid>
|
||||
$6.items
|
||||
$items
|
||||
</ul>
|
||||
</main>
|
||||
</div>
|
||||
|
@ -121,7 +121,7 @@ groupOnKey f (x:xs) = (fx, x:yes) : groupOnKey f no where
|
|||
(yes, no) = span (\y -> fx == f y) xs
|
||||
|
||||
makeFilter :: Text -> HashSet Text -> Text -> Int -> Builder
|
||||
makeFilter prefix initial tag count = [b|@0
|
||||
makeFilter prefix initial tag count = [b|
|
||||
<li$hidden>
|
||||
<input type=checkbox id="$id'" value="$tag"$checked>
|
||||
<label for="$id'" data-count=$count>$tag</label>
|
||||
|
@ -136,17 +136,17 @@ makeYearItems :: Bool -- ^ nsfw
|
|||
-> Int -- ^ year
|
||||
-> [(FilePath, Info)]
|
||||
-> Builder
|
||||
makeYearItems nsfw year infos = [b|@0
|
||||
makeYearItems nsfw year infos = [b|
|
||||
<li class="item year-marker" id="marker-$year">
|
||||
<span class=year-text>$year'</span>
|
||||
$0.items
|
||||
$items
|
||||
|]
|
||||
where
|
||||
items = map (uncurry $ makeItem nsfw) infos
|
||||
year' = show year & foldMap \c -> [b|<span class=y>$c</span>|]
|
||||
|
||||
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'"
|
||||
data-tags="$tags'">
|
||||
<a href="$dir">
|
||||
|
|
|
@ -9,7 +9,7 @@ make :: Text -> IndexInfo -> Lazy.Text
|
|||
make root info = toLazyText $ make' root info
|
||||
|
||||
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>
|
||||
<html lang=en>
|
||||
<meta charset=utf-8>
|
||||
|
@ -37,47 +37,47 @@ make' root (IndexInfo {title, desc, galleries, links, footer}) = [b|@0
|
|||
</header>
|
||||
|
||||
<main>
|
||||
$4.galleryList
|
||||
$4.linkList
|
||||
$galleryList
|
||||
$linkList
|
||||
</main>
|
||||
|
||||
$2.footer'
|
||||
$footer'
|
||||
</div>
|
||||
|]
|
||||
where
|
||||
galleryList = if null galleries then "" else [b|@0
|
||||
galleryList = if null galleries then "" else [b|
|
||||
<nav aria-label="gallery list">
|
||||
<ul id=gallery-list class=list>
|
||||
$4.items
|
||||
$items
|
||||
</ul>
|
||||
</nav>
|
||||
|]
|
||||
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">
|
||||
<ul id=link-list class=list>
|
||||
$4.items
|
||||
$items
|
||||
</ul>
|
||||
</nav>
|
||||
|]
|
||||
where items = map makeLink links
|
||||
footer' = case footer of
|
||||
Nothing -> ""
|
||||
Just f -> [b|@0
|
||||
Just f -> [b|
|
||||
<footer>
|
||||
$2.f
|
||||
$f
|
||||
</footer>
|
||||
|]
|
||||
url = [b|$root|]
|
||||
|
||||
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>
|
||||
|]
|
||||
where nsfw = if hasNsfw filters then [b| class=nsfw|] else ""
|
||||
|
||||
makeLink :: Link -> Builder
|
||||
makeLink (Link {title, url, nsfw}) = [b|@0
|
||||
makeLink (Link {title, url, nsfw}) = [b|
|
||||
<li$nsfw'><a href=$url>$title</a>
|
||||
|]
|
||||
where nsfw' = if nsfw then [b| class=nsfw|] else ""
|
||||
|
|
|
@ -16,7 +16,7 @@ script (Just _) = [b|<script src=/script/nsfw-warning.js type=module></script>|]
|
|||
|
||||
dialog :: Maybe What -> Builder
|
||||
dialog Nothing = ""
|
||||
dialog (Just what) = [b|@0
|
||||
dialog (Just what) = [b|
|
||||
<dialog id=nsfw-dialog>
|
||||
<h1>cw: lewd art</h1>
|
||||
<img src=/style/stop_hand.svg>
|
||||
|
|
|
@ -24,7 +24,7 @@ make root name ginfo output infos =
|
|||
|
||||
make' :: Strict.Text -> Strict.Text -> GalleryInfo
|
||||
-> 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"?>
|
||||
<rss version="2.0">
|
||||
<channel>
|
||||
|
@ -33,7 +33,7 @@ make' root name ginfo@(GalleryInfo {title, desc, prefix}) output infos = [b|@0
|
|||
<description>$desc</description>
|
||||
$selflink
|
||||
|
||||
$4.items
|
||||
$items
|
||||
</channel>
|
||||
</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" />|]
|
||||
|
||||
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>
|
||||
<title>$title$suffix</title>
|
||||
<link>$link</link>
|
||||
|
@ -58,11 +58,11 @@ makeItem root prefix nsfw path info@(Info {title}) = [b|@4
|
|||
</item>
|
||||
|]
|
||||
where
|
||||
body = [b|@6
|
||||
body = [b|
|
||||
<description> <![CDATA[
|
||||
$8.image
|
||||
$8.artist
|
||||
$8.desc
|
||||
$image
|
||||
$artist
|
||||
$desc
|
||||
]]> </description>
|
||||
|]
|
||||
|
||||
|
|
|
@ -66,7 +66,7 @@ make' root siteName prefix nsfw _dataDir dir
|
|||
where path' = bigFile img
|
||||
let prefetches = map makePrefetch otherImages
|
||||
|
||||
let makeWarning w = [b|@0
|
||||
let makeWarning w = [b|
|
||||
<figcaption id=cw aria-role=button tabindex=0>
|
||||
<span id=cw-text>$w</span>
|
||||
</figcaption>
|
||||
|
@ -77,7 +77,7 @@ make' root siteName prefix nsfw _dataDir dir
|
|||
|
||||
let bgStyle = case bg of
|
||||
Default -> ""
|
||||
NoBorder -> [b|@0
|
||||
NoBorder -> [b|
|
||||
<style>
|
||||
#mainfig {
|
||||
background: transparent;
|
||||
|
@ -86,7 +86,7 @@ make' root siteName prefix nsfw _dataDir dir
|
|||
}
|
||||
</style>
|
||||
|]
|
||||
Other col -> [b|@0
|
||||
Other col -> [b|
|
||||
<style> #mainfig { background: $col; } </style>
|
||||
|]
|
||||
|
||||
|
@ -104,18 +104,18 @@ make' root siteName prefix nsfw _dataDir dir
|
|||
let nsfwDialog = NsfwWarning.dialog nsfw'
|
||||
|
||||
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 name=twitter:card content=summary_large_image>
|
||||
<meta name=twitter:image content="$url/$path">
|
||||
|]
|
||||
Just (PThumb path) -> [b|@0
|
||||
Just (PThumb path) -> [b|
|
||||
<meta property=og:image content="$url/$path">
|
||||
<meta name=twitter:card content=summary>
|
||||
|]
|
||||
Nothing -> throw $ NoThumb dir
|
||||
|
||||
pure [b|@0
|
||||
pure [b|
|
||||
<!DOCTYPE html>
|
||||
<html lang=en>
|
||||
<meta charset=utf-8>
|
||||
|
@ -136,7 +136,7 @@ make' root siteName prefix nsfw _dataDir dir
|
|||
$nsfwScript
|
||||
$bgStyle
|
||||
|
||||
$0.prefetches
|
||||
$prefetches
|
||||
|
||||
<title>$title</title>
|
||||
|
||||
|
@ -153,7 +153,7 @@ make' root siteName prefix nsfw _dataDir dir
|
|||
</h2>
|
||||
</header>
|
||||
|
||||
$2.buttonBar
|
||||
$buttonBar
|
||||
|
||||
<main>
|
||||
<figure id=mainfig>
|
||||
|
@ -164,15 +164,15 @@ make' root siteName prefix nsfw _dataDir dir
|
|||
</figure>
|
||||
|
||||
<div id=info>
|
||||
$6.artistSection
|
||||
$artistSection
|
||||
|
||||
$6.descSection
|
||||
$descSection
|
||||
|
||||
$6.updatesList
|
||||
$updatesList
|
||||
|
||||
$6.linksList
|
||||
$linksList
|
||||
|
||||
$6.tagsList
|
||||
$tagsList
|
||||
</div>
|
||||
</main>
|
||||
</div>
|
||||
|
@ -187,7 +187,7 @@ last' xs = if null xs then Nothing else Just $ last xs
|
|||
|
||||
makeArtist :: Maybe Artist -> Builder
|
||||
makeArtist Nothing = ""
|
||||
makeArtist (Just (Artist {name, url})) = [b|@0
|
||||
makeArtist (Just (Artist {name, url})) = [b|
|
||||
<section id=desc class=info-section>
|
||||
<h2>by</h2>
|
||||
<div>$artistLink</div>
|
||||
|
@ -200,25 +200,25 @@ makeArtist (Just (Artist {name, url})) = [b|@0
|
|||
|
||||
makeDesc :: Desc -> Builder
|
||||
makeDesc NoDesc = ""
|
||||
makeDesc (TextDesc desc) = [b|@0
|
||||
makeDesc (TextDesc desc) = [b|
|
||||
<section id=desc class=info-section>
|
||||
<h2>about</h2>
|
||||
<div>
|
||||
$4.desc
|
||||
$desc
|
||||
</div>
|
||||
</section>
|
||||
|]
|
||||
makeDesc (LongDesc fs) = [b|@0
|
||||
makeDesc (LongDesc fs) = [b|
|
||||
<section id=desc class=info-section>
|
||||
$2.fields
|
||||
$fields
|
||||
</section>
|
||||
|]
|
||||
where
|
||||
fields = map makeField fs
|
||||
makeField (DescField {name, text}) = [b|@0
|
||||
makeField (DescField {name, text}) = [b|
|
||||
<h2>$name</h2>
|
||||
<div>
|
||||
$4.text
|
||||
$text
|
||||
</div>
|
||||
|]
|
||||
|
||||
|
@ -262,25 +262,25 @@ makeButtonBar title images =
|
|||
makeNav "cat" $ fmap (uncurry makeCat) cats
|
||||
where
|
||||
makeNav :: CanBuild b => Text -> b -> Builder
|
||||
makeNav cls inner = [b|@0
|
||||
makeNav cls inner = [b|
|
||||
<nav id=alts class=$cls aria-label="alternate versions">
|
||||
$2.inner
|
||||
$2.skipAll
|
||||
$inner
|
||||
$skipAll
|
||||
</nav> |]
|
||||
makeCat lbl imgs = [b|@0
|
||||
makeCat lbl imgs = [b|
|
||||
<section>
|
||||
<h3 class=alt-cat>$lbl</h3>
|
||||
$0.alts
|
||||
$alts
|
||||
</section> |]
|
||||
where alts = makeAlts imgs
|
||||
makeAlts imgs = [b|@0
|
||||
makeAlts imgs = [b|
|
||||
<ul class="buttonbar bb-choice">
|
||||
$2.elems
|
||||
$elems
|
||||
</ul> |]
|
||||
where elems = fmap (uncurry altButton) imgs
|
||||
skipAll =
|
||||
if any (isJust . (.warning) . fst) images then
|
||||
[b|@0
|
||||
[b|
|
||||
<div class=buttonbar id=skipAllDiv>
|
||||
<input type=checkbox name=skipAll id=skipAll>
|
||||
<label for=skipAll>skip warnings</label>
|
||||
|
@ -294,7 +294,7 @@ flatten =
|
|||
fmap (\(t, is) -> fmap (\(i, _) -> i {label = t}) is)
|
||||
|
||||
altButton :: Image -> Text -> Builder
|
||||
altButton img i = [b|@0
|
||||
altButton img i = [b|
|
||||
<li$nsfwClass>
|
||||
<input type=radio name=variant id="$i" value="$path'"
|
||||
data-link="$link"$warning'>
|
||||
|
@ -310,11 +310,11 @@ altButton img i = [b|@0
|
|||
|
||||
makeTags :: FilePath -> [Strict.Text] -> Builder
|
||||
makeTags undir tags =
|
||||
if null tags then "" else [b|@0
|
||||
if null tags then "" else [b|
|
||||
<nav id=tags class=info-section>
|
||||
<h2>tags</h2>
|
||||
<ul>
|
||||
$4.tagList
|
||||
$tagList
|
||||
</ul>
|
||||
</nav>
|
||||
|]
|
||||
|
@ -325,18 +325,18 @@ makeTags undir tags =
|
|||
|
||||
extLinks :: [Link] -> Builder
|
||||
extLinks links =
|
||||
if null links then "" else [b|@0
|
||||
if null links then "" else [b|
|
||||
<nav id=links class=info-section>
|
||||
<h2>links</h2>
|
||||
<ul>
|
||||
$4.linkList
|
||||
$linkList
|
||||
</ul>
|
||||
</nav>
|
||||
|]
|
||||
where linkList = map extLink links
|
||||
|
||||
extLink :: Link -> Builder
|
||||
extLink (Link {title, url}) = [b|@8
|
||||
extLink (Link {title, url}) = [b|
|
||||
<li>
|
||||
<a href="$url">
|
||||
$title
|
||||
|
@ -345,18 +345,18 @@ extLink (Link {title, url}) = [b|@8
|
|||
|
||||
makeUpdates :: [(Date, NonEmpty Update)] -> Builder
|
||||
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>
|
||||
<h2>updates</h2>
|
||||
<dl>
|
||||
$8.updateList
|
||||
$updateList
|
||||
</dl>
|
||||
</section>
|
||||
|]
|
||||
where updateList = fmap (uncurry makeUpdate) ups
|
||||
|
||||
makeUpdate :: Date -> NonEmpty Update -> Builder
|
||||
makeUpdate date ups = [b|@8
|
||||
makeUpdate date ups = [b|
|
||||
<dt>$date'
|
||||
<dd>$desc
|
||||
|] where
|
||||
|
|
Loading…
Reference in a new issue