82 lines
2.8 KiB
Haskell
82 lines
2.8 KiB
Haskell
{-# LANGUAGE PatternSynonyms, TemplateHaskell #-}
|
|
module BuilderQQ
|
|
(b, Builder, toStrictText, toLazyText, fromText, fromString,
|
|
ifJust, escId, escAttr, CanBuild (..))
|
|
where
|
|
|
|
import Data.Char (isSpace, isAlphaNum)
|
|
import Language.Haskell.TH
|
|
import Language.Haskell.TH.Quote
|
|
import Data.List (dropWhileEnd)
|
|
import Data.Maybe (mapMaybe, fromMaybe)
|
|
import Data.Text.Lazy.Builder
|
|
(Builder, fromText, fromLazyText, fromString, singleton, toLazyText)
|
|
import qualified Data.Text as Strict
|
|
import qualified Data.Text.Lazy as Lazy
|
|
import Data.Text.Lazy (toStrict)
|
|
import Data.List.NonEmpty (NonEmpty, toList)
|
|
|
|
data Chunk = Lit String | Var String
|
|
|
|
parseB :: String -> ExpQ
|
|
parseB = toExpQ . reverse . go "" [] . trim where
|
|
trim = dropWhileEnd isSpace . dropWhile (== '\n')
|
|
go acc cs [] = addLit acc cs
|
|
go acc cs ('$':'&':rest) = go acc cs rest -- $&: expands to nothing
|
|
go acc cs ('$':'$':rest) = go ('$' : acc) cs rest -- $$: expands to one $
|
|
go acc cs ('$':rest) = go "" (Var var : addLit acc cs) rest' -- $var
|
|
where (var, rest') = span isIdChar rest
|
|
go acc cs (c:rest) = go (c : acc) cs rest
|
|
|
|
addLit l cs = if null l then cs else Lit (reverse l) : cs
|
|
isIdChar c = isAlphaNum c || c `elem` ("_'" :: String)
|
|
|
|
toExpQ cs = [|mconcat $(listE $ mapMaybe chunk1 cs) :: Builder|]
|
|
chunk1 (Lit lit) = Just $ stringE lit
|
|
chunk1 (Var name) = Just $ [|build $(varE $ mkName name)|]
|
|
|
|
|
|
toStrictText :: Builder -> Strict.Text
|
|
toStrictText = toStrict . toLazyText
|
|
|
|
b :: QuasiQuoter
|
|
b = QuasiQuoter parseB undefined undefined undefined
|
|
|
|
|
|
ifJust :: Monoid b => Maybe a -> (a -> b) -> b
|
|
ifJust x f = maybe mempty f x
|
|
|
|
|
|
escId :: Strict.Text -> Builder
|
|
escId = foldMap esc1 . Strict.unpack where
|
|
esc1 c | isSpace c = ""
|
|
| latin1Special c = "_"
|
|
| otherwise = singleton c
|
|
latin1Special c =
|
|
c <= 'ÿ' && not (isAlphaNum c) && c /= '-'
|
|
|
|
escAttr :: Strict.Text -> Builder
|
|
escAttr = foldMap esc1 . Strict.unpack where
|
|
esc1 c = fromMaybe (singleton c) $ lookup c
|
|
[('<', "<"), ('>', ">"), ('"', """), ('\'', "'")]
|
|
|
|
|
|
class CanBuild a where build :: a -> Builder
|
|
|
|
instance CanBuild Builder where build = id
|
|
instance CanBuild Strict.Text where build = fromText
|
|
instance CanBuild Lazy.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"
|
|
|
|
instance CanBuild a => CanBuild (NonEmpty a) where build = build . toList
|