use class instead of twigils for builder

make-pages/BuilderQQ.hs

@@ -8,12 +8,14 @@ where
 import Data.Char (isLower, isSpace, isDigit, isAlphaNum)
 import Language.Haskell.TH
 import Language.Haskell.TH.Quote
+import Data.List (intersperse)
 import Data.Maybe (mapMaybe)
 import Data.Text.Lazy.Builder
-  (Builder, fromText, fromString, singleton, toLazyText)
+  (Builder, fromText, fromLazyText, fromString, singleton, toLazyText)
 import Text.Read (readMaybe)
 import Data.Text (Text)
 import qualified Data.Text as Text
+import qualified Data.Text.Lazy as LText
 import Data.Text.Lazy (toStrict)
 import Data.Foldable
 import Data.Semigroup
@@ -21,36 +23,31 @@ import Data.Semigroup
 data ChunkType = Lit | Var VarType deriving Show
 data VarType =
     Plain
-  | FromText
-  | FromString
-  | FromChar
-  | Show
   | Reindent !Int
-  | ReindentList !Int
   deriving Show
 type Chunk = (ChunkType, Text)
 
-indent :: Int -> Text -> Builder
+indent :: Int -> LText.Text -> Builder
 indent i str
-  | Text.all isSpace str = ""
-  | otherwise            = replicateB i ' ' <> fromText str
+  | LText.all isSpace str = ""
+  | otherwise             = replicateB i ' ' <> fromLazyText str
 
-reindent :: Int -> Text -> Builder
-reindent i str =
-  fold $ mapInit (<> "\n") $
-  map2 (fromText . dropIndent) (indent i . dropIndent) ls
+reindentB :: Int -> Builder -> Builder
+reindentB i (toLazyText -> str) =
+  fold $ intersperse "\n" $
+  map2 (fromLazyText . dropIndent) (indent i . dropIndent) ls
  where
-  ls  = dropWhile (Text.all isSpace) $ Text.lines str
-  ls' = filter (Text.any $ not . isSpace) ls
+  ls  = dropWhile (LText.all isSpace) $ LText.lines str
+  ls' = filter (LText.any $ not . isSpace) ls
 
-  dropIndent = Text.drop minIndent
+  dropIndent = LText.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 (' '  :.. cs) = go (n + 1) cs
+    go n ('\t' :.. cs) = go (((n `mod` 8) + 1) * 8) cs
     go n _            = n
 
   map2 _ _ []     = []
@@ -68,38 +65,12 @@ chunks = reverse . go "" [] . trimEnd where
   -- $$: 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 (singleton $var)
-  go acc cs ('$' :. '\'' :. rest) =
-      go "" ((Var FromChar, 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
+  -- $n.var (n a number): expands to builder var indented by n
   go acc cs ('$' :. rest@(d :. _)) | isDigit d =
-      go "" ((Var ty, var) : lit acc : cs) rest3
+      go "" ((Var (Reindent n), var) : lit acc : cs) rest3
     where
-      (n', c :. rest2) = Text.span isDigit rest
-      n = read $ Text.unpack n'
+      ((read . Text.unpack -> n), '.' :. rest2) = Text.span isDigit rest
       (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) =
@@ -132,35 +103,18 @@ toStrictText = toStrict . toLazyText
 
 
 chunksToExpQ :: [Chunk] -> ExpQ
-chunksToExpQ cs = [|mconcat $es|] where
+chunksToExpQ cs = [|mconcat $es :: Builder|] where
   es = listE $ mapMaybe chunk1 cs
   chunk1 (Lit, "")     = Nothing
   chunk1 (Lit, lit)    = Just $ stringE $ Text.unpack lit
   chunk1 (Var t, name) = Just $ case t of
-      Plain          -> var
-      FromText       -> [|fromText $var|]
-      FromString     -> [|fromString $var|]
-      FromChar       -> [|singleton $var|]
-      Show           -> [|fromString $ show $var|]
+      Plain          -> [|build $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,
@@ -181,6 +135,12 @@ pattern c :. t <- (Text.uncons -> Just (c, t))
 
 {-# COMPLETE NilT, (:.) :: Text #-}
 
+infixr 5 :..
+pattern (:..) :: Char -> LText.Text -> LText.Text
+pattern c :.. t <- (LText.uncons -> Just (c, t))
+  where c :.. t = LText.cons c t
+
+
 fromChar :: Char -> Builder
 fromChar = singleton
 
@@ -198,3 +158,25 @@ escId = foldMap esc1 . Text.unpack where
          | otherwise       = fromChar c
   latin1Special c =
     c <= 'ÿ' && not (isAlphaNum c) && c /= '-'
+
+
+class CanBuild a where
+  build :: a -> Builder
+  reindent :: Int -> a -> Builder
+  reindent i = reindentB i . build
+
+instance CanBuild Builder    where build = id
+instance CanBuild Text       where build = fromText
+instance CanBuild LText.Text where build = fromLazyText
+instance CanBuild Char       where build = singleton
+instance CanBuild String     where build = fromString
+
+newtype ShowBuild a = ShowBuild a deriving newtype Show
+instance Show a => CanBuild (ShowBuild a) where build = build . show
+
+deriving via ShowBuild Int     instance CanBuild Int
+deriving via ShowBuild Integer instance CanBuild Integer
+
+instance {-# OVERLAPPABLE #-} CanBuild a => CanBuild [a] where
+  build = foldMap \x -> build x <> "\n"
+  reindent n = fold . intersperse ("\n" <> replicateB n ' ') . map build