rename BuildVar module to BuilderQQ

make-pages/BuilderQQ.hs

@@ -0,0 +1,169 @@
+{-# LANGUAGE TemplateHaskell #-}
+module BuilderQQ (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
+  | FromString
+  | 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 $var)
+  go acc cs ('$' :. '@' :. rest) =
+      go "" ((Var FromString, 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 isIdChar s,
+      isLower (Text.head var)
+    = (var, s')
+  splitVar _ = error "invalid variable name"
+
+  isIdChar c = isAlphaNum c || c `elem` ['_', '\'']
+
+  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|]
+      FromString     -> [|fromString $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 #-}