gallery/make-pages/BuildVar.hs

168 lines
4.7 KiB
Haskell
Raw Normal View History

2020-07-12 22:01:31 -04:00
{-# 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
| FromString
2020-07-12 22:01:31 -04:00
| 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
2020-07-12 22:01:31 -04:00
-- $^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|]
FromString -> [|fromString $var|]
2020-07-12 22:01:31 -04:00
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 #-}