module Text.QuasiText (embed, Chunk (..), getChunks) where
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Language.Haskell.TH
import Language.Haskell.Meta (parseExp)
import Data.Attoparsec.Text
import Data.Text as T (Text, pack, unpack, append, empty, head, strip)
instance Lift Text where
lift t = litE (stringL (unpack t))
data Chunk =
T Text
| E Text
| V Text
deriving (Show, Eq)
class Textish a where
toText :: a -> Text
instance Textish Text where
toText = id
instance Textish [Char] where
toText = pack
instance Show a => Textish a where
toText = pack . show
embed :: QuasiQuoter
embed = QuasiQuoter
{ quoteExp = \s ->
let chunks = flip map (getChunks (pack s)) $ \c ->
case c of
T t -> [| t |]
E t -> let Right e = parseExp (unpack t) in appE [| toText |] (return e)
V t | T.head t `elem` ['a'..'z'] -> appE [| toText |] (global (mkName (unpack t)))
| otherwise -> let Right e = parseExp (unpack t) in appE [| toText |] (return e)
in foldr (\l r -> appE (appE [| append |] l) r) [| empty |] chunks
, quotePat = error "cannot use this as a pattern"
, quoteDec = error "cannot use this as a declaration"
, quoteType = error "cannot use this as a type"
}
getChunks :: Text -> [Chunk]
getChunks i = let Right m = parseOnly parser (strip i) in m
where
parser = go []
go s = do
txt <- takeTill (== '$')
evt <- choice [expression, var, fmap T takeText]
end <- atEnd
if end
then return $ filter (not . blank) $ reverse (evt:T txt:s)
else go (evt:T txt:s)
blank (T "") = True
blank (E "") = True
blank (V "") = True
blank _ = False
var = do
char '$'
val <- takeTill (notInClass "a-zA-Z0-9_")
return (V val)
expression = do
string "$("
expr <- takeTill (== ')')
char ')'
return (E expr)