{-# LANGUAGE TemplateHaskell #-}
module Text.Yate.TH
( ytpl
, ytplf
, loadTemplate
, loadTemplateFile
) where
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Text.Yate.Parser
import Text.Yate.Types
ytpl :: QuasiQuoter
ytpl = QuasiQuoter
{ quoteExp = loadTemplate
, quotePat = error "The tpl quasiquoter is only for expressions"
, quoteType = error "The tpl quasiquoter is only for expressions"
, quoteDec = error "The tpl quasiquoter is only for expressions"
}
ytplf :: QuasiQuoter
ytplf = quoteFile ytpl
loadTemplate :: String -> Q Exp
loadTemplate str = case parseTemplate $ T.pack str of
Left err -> fail $ "Failed to parse template: " ++ err
Right tpl -> templateToExp (tpl :: Template ())
loadTemplateFile :: FilePath -> Q Exp
loadTemplateFile path = do
content <- runIO $ readFile path
loadTemplate content
templateToExp :: Template a -> Q Exp
templateToExp tpl = case tpl of
Content txt -> [| Content $(litE $ StringL $ TL.unpack txt) |]
Variable path -> [| Variable $(pathToExp path) |]
If path yes no ->
[| If $(pathToExp path) $(templateToExp yes) $(templateToExp no) |]
For name path block ->
[| For $(litE $ StringL $ T.unpack name) $(pathToExp path)
$(templateToExp block) |]
In path block -> [| In $(pathToExp path) $(templateToExp block) |]
Parts parts -> [| Parts $(listE $ map templateToExp parts) |]
pathToExp :: Path -> Q Exp
pathToExp path = case path of
AbsolutePath names -> [| AbsolutePath $(mkNameList names) |]
RelativePath names -> [| RelativePath $(mkNameList names) |]
where
mkNameList :: [T.Text] -> Q Exp
mkNameList names = listE $ map (litE . StringL . T.unpack) names