make quasiquoter for text building
This commit is contained in:
parent
55a51464ee
commit
22185e3020
3 changed files with 265 additions and 92 deletions
|
|
@ -1,6 +1,8 @@
|
|||
module SinglePage (make) where
|
||||
|
||||
import Info hiding (Text)
|
||||
import BuildVar
|
||||
|
||||
import Control.Exception
|
||||
import qualified Data.Text as Strict
|
||||
import qualified Data.Text.Lazy as Lazy
|
||||
|
|
@ -26,80 +28,88 @@ make includeNsfw = toLazyText . make' includeNsfw
|
|||
|
||||
make' :: Bool -> Info -> Builder
|
||||
make' includeNsfw (Info {date, title, tags, nsfwTags,
|
||||
description, images, links}) =
|
||||
"<!DOCTYPE html>\n" <>
|
||||
"<html lang=en>\n" <>
|
||||
"<meta charset=utf-8>\n" <>
|
||||
"<link href=single.css rel=stylesheet>\n\n" <>
|
||||
ifJust title (\t -> "<title>" <> esc t <> "</title>\n\n") <>
|
||||
"<header>\n" <>
|
||||
ifJust title (\t -> " <h1>" <> esc t <> "</h1>\n") <>
|
||||
" <h2 class=date>" <> formatDate date <> "</h2>\n" <>
|
||||
buttonBar title' includeNsfw images <>
|
||||
"</header>\n\n" <>
|
||||
"<main>\n" <>
|
||||
" <img id=it src=\"" <> path0 <> "\">\n\n" <>
|
||||
ifJust description (\d ->
|
||||
" <div class=desc>\n" <>
|
||||
" <h2>description</h2>\n" <>
|
||||
indent 4 d <>
|
||||
" </div>\n") <> "\n" <>
|
||||
makeTags includeNsfw tags nsfwTags <>
|
||||
extLinks includeNsfw links <>
|
||||
"</main>\n\n" <>
|
||||
"<footer>\n" <>
|
||||
" <nav class=back>\n" <>
|
||||
" <a href=../>back to gallery</a>\n" <>
|
||||
" </nav>\n" <>
|
||||
"</footer>\n"
|
||||
where
|
||||
path0' = let Image {path} = head images in path
|
||||
path0 = fromText path0'
|
||||
title' = fromMaybe path0' title
|
||||
description, images, links}) = [b|@0
|
||||
<!DOCTYPE html>
|
||||
<html lang=en>
|
||||
<meta charset=utf-8>
|
||||
$titleTag
|
||||
|
||||
<header>
|
||||
$titleHeader
|
||||
<h2 class=date>$formattedDate</date>
|
||||
$buttonBar
|
||||
</header>
|
||||
|
||||
<main>
|
||||
<img id=it src="$*path0">
|
||||
|
||||
$descSection
|
||||
|
||||
$tagsList
|
||||
|
||||
$linksList
|
||||
</main>
|
||||
|
||||
<footer>
|
||||
<nav class=back>
|
||||
<a href=../>back to gallery</a>
|
||||
</nav>
|
||||
</footer>
|
||||
|]
|
||||
where
|
||||
titleTag = ifJust title \t -> [b|<title>$*t</title>|]
|
||||
titleHeader = ifJust title \t -> [b|<h1>$*t</h1>|]
|
||||
formattedDate = formatDate date
|
||||
buttonBar = makeButtonBar (fromMaybe path0 title) includeNsfw images
|
||||
path0 = let Image {path} = head images in path
|
||||
|
||||
descSection = ifJust description makeDesc
|
||||
tagsList = makeTags includeNsfw tags nsfwTags
|
||||
linksList = extLinks includeNsfw links
|
||||
|
||||
makeDesc :: Strict.Text -> Builder
|
||||
makeDesc desc = [b|@2
|
||||
<div class=desc>
|
||||
<h2>description</h2>
|
||||
$4*desc
|
||||
</div>
|
||||
|]
|
||||
|
||||
ifJust :: Monoid b => Maybe a -> (a -> b) -> b
|
||||
ifJust x f = maybe mempty f x
|
||||
|
||||
esc :: Strict.Text -> Builder
|
||||
esc = foldMap esc1 . Strict.unpack where
|
||||
esc1 '<' = "<"
|
||||
esc1 '>' = ">"
|
||||
esc1 '&' = "&"
|
||||
esc1 '"' = """
|
||||
esc1 '\'' = "&squot;"
|
||||
esc1 c = singleton c
|
||||
|
||||
formatDate :: Day -> Builder
|
||||
formatDate = fromString . formatTime defaultTimeLocale "%e %#B %Y"
|
||||
|
||||
buttonBar :: Strict.Text -> Bool -> [Image] -> Builder
|
||||
buttonBar title includeNsfw allImages =
|
||||
if null images then
|
||||
throw $ NoEligibleImages title
|
||||
else if length images == 1 then
|
||||
mempty
|
||||
else
|
||||
" <nav id=variants class=buttonbar>\n" <>
|
||||
" <h2>alts</h2>\n" <>
|
||||
" <ul id=variantlist>\n" <>
|
||||
List.foldl' (\b (i, im) -> b <> altButton i im) mempty iimages <>
|
||||
" </ul>\n" <>
|
||||
" </nav>\n"
|
||||
makeButtonBar :: Strict.Text -> Bool -> [Image] -> Builder
|
||||
makeButtonBar title includeNsfw allImages =
|
||||
case length images of
|
||||
0 -> throw $ NoEligibleImages title
|
||||
1 -> ""
|
||||
_ -> [b|@2
|
||||
<nav id=variants class=buttonbar>
|
||||
<h2>alts</h2>
|
||||
<ul id=variantlist>
|
||||
$6.alts
|
||||
</ul>
|
||||
</nav>
|
||||
|]
|
||||
where
|
||||
images | includeNsfw = allImages
|
||||
| otherwise = filter (\Image {nsfw} -> not nsfw) allImages
|
||||
iimages = zip [0..] images
|
||||
alts = map (uncurry altButton) iimages
|
||||
|
||||
altButton :: Int -> Image -> Builder
|
||||
altButton i (Image {label, path, nsfw}) =
|
||||
" <li" <> nsfwClass <> ">\n" <>
|
||||
" <input type=radio " <> checked <> "id=\"" <> idLabel <> "\" " <>
|
||||
"name=variant autocomplete=off\n" <>
|
||||
" value=\"" <> fromText path <> "\">\n" <>
|
||||
" <label for=\"" <> idLabel <> "\">" <> fromText label <> "</label>\n"
|
||||
altButton i (Image {label, path, nsfw}) = [b|@6
|
||||
<li$nsfwClass>
|
||||
<input type=radio$checked id="$idLabel" name=variant
|
||||
autocomplete=off value="$*path">
|
||||
<label for="$idLabel">$*label</label>
|
||||
|]
|
||||
where
|
||||
nsfwClass = if nsfw then " class=nsfw" else ""
|
||||
checked = if i == 0 then "checked " else ""
|
||||
checked = if i == 0 then " checked" else ""
|
||||
idLabel = escId label
|
||||
|
||||
escId :: Strict.Text -> Builder
|
||||
|
|
@ -109,41 +119,40 @@ escId = foldMap esc1 . Strict.unpack where
|
|||
| c < 'ÿ' && not (Char.isAlphaNum c || c == '-') = "_"
|
||||
| otherwise = singleton c
|
||||
|
||||
indent :: Int -> Strict.Text -> Builder
|
||||
indent n txt = spaces <> go (Strict.unpack txt) where
|
||||
go "" = mempty
|
||||
go "\n" = "\n"
|
||||
go ('\n':cs) = singleton '\n' <> spaces <> go cs
|
||||
go (c:cs) = singleton c <> go cs
|
||||
spaces = fromString $ replicate n ' '
|
||||
|
||||
makeTags :: Bool -> [Strict.Text] -> [Strict.Text] -> Builder
|
||||
makeTags includeNsfw sfwTags nsfwTags =
|
||||
if null tags then mempty else
|
||||
" <div class=tags>\n" <>
|
||||
" <h2>tags</h2>\n" <>
|
||||
" <ul>\n" <> foldMap makeTag tags <> " </ul>\n" <>
|
||||
" </div>\n\n"
|
||||
if null tags then "" else [b|@2
|
||||
<div class=tags>
|
||||
<h2>tags</h2>
|
||||
<ul>
|
||||
$6.tagList
|
||||
</ul>
|
||||
</div>
|
||||
|]
|
||||
where
|
||||
tagList = map makeTag tags
|
||||
makeTag t = [b|<li>$*t|]
|
||||
tags = List.nub $ if includeNsfw then sfwTags else sfwTags <> nsfwTags
|
||||
makeTag t = " <li>" <> fromText t <> "\n"
|
||||
|
||||
extLinks :: Bool -> [Link] -> Builder
|
||||
extLinks includeNsfw links =
|
||||
let links' =
|
||||
if includeNsfw then links
|
||||
else filter (\Link {nsfw} -> not nsfw) links in
|
||||
if null links' then mempty else
|
||||
" <div class=links>\n" <>
|
||||
" <h2>links</h2>\n" <>
|
||||
" <ul>\n" <>
|
||||
foldMap extLink links' <>
|
||||
" </ul>\n" <>
|
||||
" </div>\n"
|
||||
extLinks includeNsfw allLinks =
|
||||
if null links then "" else [b|@2
|
||||
<div class=links>
|
||||
<h2>links</h2>
|
||||
<ul>
|
||||
$6.linkList
|
||||
</ul>
|
||||
</div>
|
||||
|]
|
||||
where
|
||||
links | includeNsfw = allLinks
|
||||
| otherwise = filter (\Link {nsfw} -> not nsfw) allLinks
|
||||
linkList = map extLink links
|
||||
|
||||
extLink :: Link -> Builder
|
||||
extLink (Link {title, url}) =
|
||||
" <li>\n" <>
|
||||
" <a href=\"" <> fromText url <> "\">\n" <>
|
||||
" " <> fromText title <> "\n" <>
|
||||
" </a>\n"
|
||||
extLink (Link {title, url}) = [b|@6
|
||||
<li>
|
||||
<a href="$*url">
|
||||
$*title
|
||||
</a>
|
||||
|]
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue