{-# LANGUAGE DeriveDataTypeable, QuasiQuotes #-}
module Text.StringTemplate.QQ (stmp) where
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH.Quote
import Text.StringTemplate.Base
import qualified Data.Set as S
quoteTmplExp :: String -> TH.ExpQ
quoteTmplPat :: String -> TH.PatQ
stmp :: QuasiQuoter
stmp :: QuasiQuoter
stmp = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter {quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
quoteTmplExp, quotePat :: String -> Q Pat
quotePat = String -> Q Pat
quoteTmplPat}
quoteTmplPat :: String -> Q Pat
quoteTmplPat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"Cannot apply stmp quasiquoter in patterns"
quoteTmplExp :: String -> Q Exp
quoteTmplExp String
s = Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
tmpl
where
vars :: [String]
vars = case (Char, Char)
-> String -> Either ParseError ([String], [String], [String])
parseSTMPNames (Char
'$',Char
'$') String
s of
Right ([String]
xs,[String]
_,[String]
_) -> [String]
xs
Left ParseError
err -> String -> [String]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ ParseError -> String
forall a. Show a => a -> String
show ParseError
err
base :: Exp
base = Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE (String -> Name
TH.mkName String
"Text.StringTemplate.newSTMP")) (Lit -> Exp
TH.LitE (String -> Lit
TH.StringL String
s))
tmpl :: Exp
tmpl = (String -> Exp -> Exp) -> Exp -> Set String -> Exp
forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr String -> Exp -> Exp
addAttrib Exp
base (Set String -> Exp) -> Set String -> Exp
forall a b. (a -> b) -> a -> b
$ [String] -> Set String
forall a. Ord a => [a] -> Set a
S.fromList [String]
vars
addAttrib :: String -> Exp -> Exp
addAttrib String
var = Exp -> Exp -> Exp
TH.AppE
(Exp -> Exp -> Exp
TH.AppE (Exp -> Exp -> Exp
TH.AppE (Name -> Exp
TH.VarE (String -> Name
TH.mkName String
"Text.StringTemplate.setAttribute"))
(Lit -> Exp
TH.LitE (String -> Lit
TH.StringL (Char
'`' Char -> String -> String
forall a. a -> [a] -> [a]
: String
var String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"`"))))
(Name -> Exp
TH.VarE (String -> Name
TH.mkName String
var)))