module Text.QuasiText (embed, Chunk (..), getChunks) where
import Instances.TH.Lift ()
import Language.Haskell.TH.Quote
import Language.Haskell.TH.Syntax
import Language.Haskell.TH
import Language.Haskell.Meta (parseExp)
import Data.Attoparsec.Text
import qualified Data.Text as T
import Data.Text (Text)
import Data.Char
import Data.Monoid
import Control.Applicative
data Chunk
= T Text
| E Text
| V Text
deriving (Show, Eq)
class Textish a where
toText :: a -> Text
instance Textish Text where
toText x = x
instance Textish [Char] where
toText x = T.pack x
instance Show a => Textish a where
toText x = T.pack (show x)
embed :: QuasiQuoter
embed = QuasiQuoter
{ quoteExp = \s ->
let chunks = flip map (getChunks (T.pack s)) $ \c ->
case c of
T t -> [| t |]
E t -> case parseExp (T.unpack t) of
Left e -> error e
Right e -> appE [| toText |] (return e)
V t -> appE [| toText |] (varE (mkName (T.unpack t)))
in appE [| T.concat |] (listE chunks)
}
getChunks :: Text -> [Chunk]
getChunks i = case parseOnly parser (T.strip i) of
Right m -> m
_ -> error "Unclosed parenthesis."
where
parenthesis '(' = True
parenthesis ')' = True
parenthesis _ = False
parseExpression :: Int -> Parser [Text]
parseExpression level = do
expr <- takeTill parenthesis
paren <- anyChar
case paren of
')' | level <= 0 -> return [expr]
| otherwise -> do
next <- parseExpression (level 1)
return ([expr, ")"] ++ next)
'(' -> do
next <- parseExpression (level + 1)
return ([expr, "("] ++ next)
_ -> return [expr, T.singleton paren]
parser :: Parser [Chunk]
parser = fmap concat $ flip manyTill endOfInput $ do
text <- takeTill (== '$')
end <- atEnd
if end
then return [T text]
else do
char '$'
next <- anyChar
case next of
'(' -> do
expr <- T.concat <$> parseExpression 0
return [T text, E expr]
'$' -> return [T (text <> "$")]
_ -> do
name <- takeTill (not . isAlphaNum)
return [T text, V (T.cons next name)]