diff --git a/make-pages/BuildVar.hs b/make-pages/BuildVar.hs
new file mode 100644
index 0000000..ff5e368
--- /dev/null
+++ b/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 #-}
diff --git a/make-pages/SinglePage.hs b/make-pages/SinglePage.hs
index 807ed91..7f968b4 100644
--- a/make-pages/SinglePage.hs
+++ b/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}) =
- "\n" <>
- "\n" <>
- "\n" <>
- "\n\n" <>
- ifJust title (\t -> "" <> esc t <> "\n\n") <>
- "\n" <>
- ifJust title (\t -> " " <> esc t <> "
\n") <>
- " " <> formatDate date <> "
\n" <>
- buttonBar title' includeNsfw images <>
- "\n\n" <>
- "\n" <>
- " ![](\"")
path0 <> "\">\n\n" <>
- ifJust description (\d ->
- " \n" <>
- "
description
\n" <>
- indent 4 d <>
- " \n") <> "\n" <>
- makeTags includeNsfw tags nsfwTags <>
- extLinks includeNsfw links <>
- "\n\n" <>
- "\n"
- where
- path0' = let Image {path} = head images in path
- path0 = fromText path0'
- title' = fromMaybe path0' title
+ description, images, links}) = [b|@0
+
+
+
+ $titleTag
+
+
+ $titleHeader
+ $formattedDate
+ $buttonBar
+
+
+
+ 
+
+ $descSection
+
+ $tagsList
+
+ $linksList
+
+
+
+ |]
+ where
+ titleTag = ifJust title \t -> [b|$*t|]
+ titleHeader = ifJust title \t -> [b|$*t
|]
+ 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
+
+
description
+ $4*desc
+
+ |]
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
- " \n"
+makeButtonBar :: Strict.Text -> Bool -> [Image] -> Builder
+makeButtonBar title includeNsfw allImages =
+ case length images of
+ 0 -> throw $ NoEligibleImages title
+ 1 -> ""
+ _ -> [b|@2
+
+ |]
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}) =
- " nsfwClass <> ">\n" <>
- " checked <> "id=\"" <> idLabel <> "\" " <>
- "name=variant autocomplete=off\n" <>
- " value=\"" <> fromText path <> "\">\n" <>
- " \n"
+altButton i (Image {label, path, nsfw}) = [b|@6
+
+
+
+ |]
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
- " \n\n"
+ if null tags then "" else [b|@2
+
+ |]
where
+ tagList = map makeTag tags
+ makeTag t = [b|$*t|]
tags = List.nub $ if includeNsfw then sfwTags else sfwTags <> nsfwTags
- makeTag t = " " <> 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
- " \n" <>
- "
links
\n" <>
- "
\n" <>
- foldMap extLink links' <>
- "
\n" <>
- "