make quasiquoter for text building

make-pages/BuildVar.hs

@@ -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 #-}

make-pages/SinglePage.hs

@@ -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}) =
+                         description, images, links}) = [b|@0
- "<!DOCTYPE html>\n" <>
+    <!DOCTYPE html>
- "<html lang=en>\n" <>
+    <html lang=en>
- "<meta charset=utf-8>\n" <>
+    <meta charset=utf-8>
- "<link href=single.css rel=stylesheet>\n\n" <>
+    $titleTag
- ifJust title (\t -> "<title>" <> esc t <> "</title>\n\n") <>
+
- "<header>\n" <>
+    <header>
-    ifJust title (\t -> "  <h1>" <> esc t <> "</h1>\n") <>
+      $titleHeader
- "  <h2 class=date>" <> formatDate date <> "</h2>\n" <>
+      <h2 class=date>$formattedDate</date>
-    buttonBar title' includeNsfw images <>
+      $buttonBar
- "</header>\n\n" <>
+    </header>
- "<main>\n" <>
+
- "  <img id=it src=\"" <> path0 <> "\">\n\n" <>
+    <main>
- ifJust description (\d ->
+      <img id=it src="$*path0">
- "  <div class=desc>\n" <>
+
- "    <h2>description</h2>\n" <>
+      $descSection
-      indent 4 d <>
+
- "  </div>\n") <> "\n" <>
+      $tagsList
-    makeTags includeNsfw tags nsfwTags <>
+
-    extLinks includeNsfw links <>
+      $linksList
- "</main>\n\n" <>
+    </main>
- "<footer>\n" <>
+
- "  <nav class=back>\n" <>
+    <footer>
- "    <a href=../>back to gallery</a>\n" <>
+      <nav class=back>
- "  </nav>\n" <>
+        <a href=../>back to gallery</a>
- "</footer>\n"
+      </nav>
- where
+    </footer>
-  path0' = let Image {path} = head images in path
+  |]
-  path0  = fromText path0'
+  where
-  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 '<'  = "&lt;"
-  esc1 '>'  = "&gt;"
-  esc1 '&'  = "&amp;"
-  esc1 '"'  = "&quot;"
-  esc1 '\'' = "&squot;"
-  esc1 c    = singleton c
-
 formatDate :: Day -> Builder
 formatDate = fromString . formatTime defaultTimeLocale "%e %#B %Y"
 
-buttonBar :: Strict.Text -> Bool -> [Image] -> Builder
+makeButtonBar :: Strict.Text -> Bool -> [Image] -> Builder
-buttonBar title includeNsfw allImages =
+makeButtonBar title includeNsfw allImages =
-  if null images then
+  case length images of
-    throw $ NoEligibleImages title
+    0 -> throw $ NoEligibleImages title
-  else if length images == 1 then
+    1 -> ""
-    mempty
+    _ -> [b|@2
-  else
+      <nav id=variants class=buttonbar>
- "  <nav id=variants class=buttonbar>\n" <>
+        <h2>alts</h2>
- "    <h2>alts</h2>\n" <>
+        <ul id=variantlist>
- "    <ul id=variantlist>\n" <>
+          $6.alts
-        List.foldl' (\b (i, im) -> b <> altButton i im) mempty iimages <>
+        </ul>
- "    </ul>\n" <>
+      </nav>
- "  </nav>\n"
+      |]
  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}) =
+altButton i (Image {label, path, nsfw}) = [b|@6
- "      <li" <> nsfwClass <> ">\n" <>
+  <li$nsfwClass>
- "        <input type=radio " <> checked <> "id=\"" <> idLabel <> "\" " <>
+    <input type=radio$checked id="$idLabel" name=variant
-                "name=variant autocomplete=off\n" <>
+           autocomplete=off value="$*path">
- "               value=\"" <> fromText path <> "\">\n" <>
+    <label for="$idLabel">$*label</label>
- "        <label for=\"" <> idLabel <> "\">" <> fromText label <> "</label>\n"
+  |]
  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
+  if null tags then "" else [b|@2
- "  <div class=tags>\n" <>
+    <div class=tags>
- "    <h2>tags</h2>\n" <>
+      <h2>tags</h2>
- "    <ul>\n" <> foldMap makeTag tags <> "    </ul>\n" <>
+      <ul>
- "  </div>\n\n"
+        $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 =
+extLinks includeNsfw allLinks =
-  let links' =
+  if null links then "" else [b|@2
-        if includeNsfw then links
+    <div class=links>
-          else filter (\Link {nsfw} -> not nsfw) links in
+      <h2>links</h2>
-  if null links' then mempty else
+      <ul>
- "  <div class=links>\n" <>
+        $6.linkList
- "    <h2>links</h2>\n" <>
+      </ul>
- "    <ul>\n" <>
+    </div>
-        foldMap extLink links' <>
+  |]
- "    </ul>\n" <>
+ where
- "  </div>\n"
+  links | includeNsfw = allLinks
+        | otherwise   = filter (\Link {nsfw} -> not nsfw) allLinks
+  linkList = map extLink links
 
 extLink :: Link -> Builder
-extLink (Link {title, url}) =
+extLink (Link {title, url}) = [b|@6
- "    <li>\n" <>
+    <li>
- "      <a href=\"" <> fromText url <> "\">\n" <>
+      <a href="$*url">
- "        " <> fromText title <> "\n" <>
+        $*title
- "      </a>\n"
+      </a>
+  |]

make-pages/make-pages.cabal

@@ -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