make quasiquoter for text building
This commit is contained in:
parent
55a51464ee
commit
22185e3020
3 changed files with 265 additions and 92 deletions
160
make-pages/BuildVar.hs
Normal file
160
make-pages/BuildVar.hs
Normal file
|
|
@ -0,0 +1,160 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module BuildVar (b) where
|
||||
|
||||
import Data.Char (isLower, isSpace, isDigit, isAlphaNum)
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Quote
|
||||
import Data.Text.Lazy.Builder
|
||||
(Builder, fromText, fromString, singleton, toLazyText)
|
||||
import Text.Read (readMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Text.Lazy (toStrict)
|
||||
import Data.Foldable
|
||||
import Data.Semigroup
|
||||
|
||||
data ChunkType = Lit | Var VarType deriving Show
|
||||
data VarType =
|
||||
Plain
|
||||
| FromText
|
||||
| Show
|
||||
| Reindent !Int
|
||||
| ReindentList !Int
|
||||
deriving Show
|
||||
type Chunk = (ChunkType, Text)
|
||||
|
||||
indent :: Int -> Text -> Builder
|
||||
indent i str
|
||||
| Text.all isSpace str = ""
|
||||
| otherwise = replicateB i ' ' <> fromText str
|
||||
|
||||
reindent :: Int -> Text -> Builder
|
||||
reindent i str =
|
||||
fold $ mapInit (<> "\n") $
|
||||
map2 (fromText . dropIndent) (indent i . dropIndent) ls
|
||||
where
|
||||
ls = dropWhile (Text.all isSpace) $ Text.lines str
|
||||
ls' = filter (Text.any $ not . isSpace) ls
|
||||
|
||||
dropIndent = Text.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 _ = n
|
||||
|
||||
map2 _ _ [] = []
|
||||
map2 f g (x:xs) = f x : map g xs
|
||||
|
||||
|
||||
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
|
||||
|
||||
-- $*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 (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 "" ((Var ty, var) : lit acc : cs) rest3
|
||||
where
|
||||
(n', c :. rest2) = Text.span isDigit rest
|
||||
n = read $ Text.unpack n'
|
||||
(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) =
|
||||
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, s') <- Text.span isAlphaNum s,
|
||||
isLower (Text.head var)
|
||||
= (var, s')
|
||||
splitVar _ = error "invalid variable name"
|
||||
|
||||
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
|
||||
|
||||
|
||||
chunksToExpQ :: [Chunk] -> ExpQ
|
||||
chunksToExpQ cs = [|$expr :: Builder|] where
|
||||
expr = foldl1 (\x y -> [|$x <> $y|]) $ map chunk1 cs
|
||||
chunk1 (Lit, lit) = stringE $ Text.unpack lit
|
||||
chunk1 (Var t, name) = case t of
|
||||
Plain -> var
|
||||
FromText -> [|fromText $var|]
|
||||
Show -> [|fromString $ show $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,
|
||||
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 #-}
|
||||
|
|
@ -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"
|
||||
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
|
||||
path0' = let Image {path} = head images in path
|
||||
path0 = fromText path0'
|
||||
title' = fromMaybe path0' title
|
||||
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>
|
||||
|]
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ maintainer: Rhiannon Morris <rhi@rhiannon.website>
|
|||
executable make-pages
|
||||
hs-source-dirs: .
|
||||
main-is: Main.hs
|
||||
other-modules: Info, SinglePage
|
||||
other-modules: Info, SinglePage, BuildVar
|
||||
default-language: Haskell2010
|
||||
default-extensions:
|
||||
BlockArguments,
|
||||
|
|
@ -18,7 +18,10 @@ executable make-pages
|
|||
DuplicateRecordFields,
|
||||
LambdaCase,
|
||||
NamedFieldPuns,
|
||||
OverloadedStrings
|
||||
OverloadedStrings,
|
||||
PatternSynonyms,
|
||||
QuasiQuotes,
|
||||
ViewPatterns
|
||||
build-depends:
|
||||
base >= 4.12.0.0 && < 4.15,
|
||||
containers ^>= 0.6.0.1,
|
||||
|
|
@ -26,6 +29,7 @@ executable make-pages
|
|||
bytestring ^>= 0.10.8.2,
|
||||
text ^>= 1.2.3.1,
|
||||
HsYAML ^>= 0.2.1.0,
|
||||
optparse-applicative ^>= 0.15.1.0
|
||||
optparse-applicative ^>= 0.15.1.0,
|
||||
template-haskell ^>= 2.16.0.0
|
||||
ghc-options:
|
||||
-Wall -threaded -rtsopts -with-rtsopts=-N
|
||||
|
|
|
|||
Loading…
Reference in a new issue