{-# OPTIONS_GHC -fno-warn-missing-fields #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Text.Mustache.Compile
( automaticCompile, localAutomaticCompile, TemplateCache, compileTemplateWithCache
, compileTemplate, cacheFromList, getPartials, mustache, embedTemplate, embedSingleTemplate
) where
import Control.Arrow ((&&&))
import Control.Monad
import Control.Monad.Except
import Control.Monad.State
import Data.Bool
import Data.HashMap.Strict as HM
import Data.Text hiding (concat, find, map, uncons)
import qualified Data.Text.IO as TIO
import Language.Haskell.TH (Exp, Loc, Q, loc_filename,
loc_start, location)
import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter),
quoteExp)
import qualified Language.Haskell.TH.Syntax as THS
import System.Directory
import System.FilePath
import Text.Mustache.Parser
import Text.Mustache.Types
import Text.Parsec.Error
import Text.Parsec.Pos
import Text.Printf
automaticCompile :: [FilePath] -> FilePath -> IO (Either ParseError Template)
automaticCompile :: [FilePath] -> FilePath -> IO (Either ParseError Template)
automaticCompile [FilePath]
searchSpace = [FilePath]
-> TemplateCache -> FilePath -> IO (Either ParseError Template)
compileTemplateWithCache [FilePath]
searchSpace TemplateCache
forall a. Monoid a => a
mempty
localAutomaticCompile :: FilePath -> IO (Either ParseError Template)
localAutomaticCompile :: FilePath -> IO (Either ParseError Template)
localAutomaticCompile = [FilePath] -> FilePath -> IO (Either ParseError Template)
automaticCompile [FilePath
"."]
compileTemplateWithCache :: [FilePath]
-> TemplateCache
-> FilePath
-> IO (Either ParseError Template)
compileTemplateWithCache :: [FilePath]
-> TemplateCache -> FilePath -> IO (Either ParseError Template)
compileTemplateWithCache [FilePath]
searchSpace TemplateCache
templates FilePath
initName =
ExceptT ParseError IO Template -> IO (Either ParseError Template)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ParseError IO Template -> IO (Either ParseError Template))
-> ExceptT ParseError IO Template
-> IO (Either ParseError Template)
forall a b. (a -> b) -> a -> b
$ StateT TemplateCache (ExceptT ParseError IO) Template
-> TemplateCache -> ExceptT ParseError IO Template
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (FilePath -> StateT TemplateCache (ExceptT ParseError IO) Template
compile' FilePath
initName) (TemplateCache -> ExceptT ParseError IO Template)
-> TemplateCache -> ExceptT ParseError IO Template
forall a b. (a -> b) -> a -> b
$ TemplateCache -> TemplateCache
flattenPartials TemplateCache
templates
where
compile' :: FilePath
-> StateT
(HM.HashMap String Template)
(ExceptT ParseError IO)
Template
compile' :: FilePath -> StateT TemplateCache (ExceptT ParseError IO) Template
compile' FilePath
name' = do
TemplateCache
templates' <- StateT TemplateCache (ExceptT ParseError IO) TemplateCache
forall s (m :: * -> *). MonadState s m => m s
get
case FilePath -> TemplateCache -> Maybe Template
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup FilePath
name' TemplateCache
templates' of
Just Template
template -> Template -> StateT TemplateCache (ExceptT ParseError IO) Template
forall (m :: * -> *) a. Monad m => a -> m a
return Template
template
Maybe Template
Nothing -> do
Text
rawSource <- ExceptT ParseError IO Text
-> StateT TemplateCache (ExceptT ParseError IO) Text
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT ParseError IO Text
-> StateT TemplateCache (ExceptT ParseError IO) Text)
-> ExceptT ParseError IO Text
-> StateT TemplateCache (ExceptT ParseError IO) Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath -> ExceptT ParseError IO Text
getFile [FilePath]
searchSpace FilePath
name'
compiled :: Template
compiled@(Template { ast :: Template -> STree
ast = STree
mSTree }) <-
ExceptT ParseError IO Template
-> StateT TemplateCache (ExceptT ParseError IO) Template
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT ParseError IO Template
-> StateT TemplateCache (ExceptT ParseError IO) Template)
-> ExceptT ParseError IO Template
-> StateT TemplateCache (ExceptT ParseError IO) Template
forall a b. (a -> b) -> a -> b
$ IO (Either ParseError Template) -> ExceptT ParseError IO Template
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either ParseError Template) -> ExceptT ParseError IO Template)
-> (Either ParseError Template -> IO (Either ParseError Template))
-> Either ParseError Template
-> ExceptT ParseError IO Template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either ParseError Template -> IO (Either ParseError Template)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ParseError Template -> ExceptT ParseError IO Template)
-> Either ParseError Template -> ExceptT ParseError IO Template
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> Either ParseError Template
compileTemplate FilePath
name' Text
rawSource
(Template
-> FilePath
-> StateT TemplateCache (ExceptT ParseError IO) Template)
-> Template
-> [FilePath]
-> StateT TemplateCache (ExceptT ParseError IO) Template
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
(\st :: Template
st@(Template { partials :: Template -> TemplateCache
partials = TemplateCache
p }) FilePath
partialName -> do
Template
nt <- FilePath -> StateT TemplateCache (ExceptT ParseError IO) Template
compile' FilePath
partialName
(TemplateCache -> TemplateCache)
-> StateT TemplateCache (ExceptT ParseError IO) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (FilePath -> Template -> TemplateCache -> TemplateCache
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert FilePath
partialName Template
nt)
Template -> StateT TemplateCache (ExceptT ParseError IO) Template
forall (m :: * -> *) a. Monad m => a -> m a
return (Template
st { partials :: TemplateCache
partials = FilePath -> Template -> TemplateCache -> TemplateCache
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert FilePath
partialName Template
nt TemplateCache
p })
)
Template
compiled
(STree -> [FilePath]
getPartials STree
mSTree)
cacheFromList :: [Template] -> TemplateCache
cacheFromList :: [Template] -> TemplateCache
cacheFromList = TemplateCache -> TemplateCache
flattenPartials (TemplateCache -> TemplateCache)
-> ([Template] -> TemplateCache) -> [Template] -> TemplateCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FilePath, Template)] -> TemplateCache
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
fromList ([(FilePath, Template)] -> TemplateCache)
-> ([Template] -> [(FilePath, Template)])
-> [Template]
-> TemplateCache
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Template -> (FilePath, Template))
-> [Template] -> [(FilePath, Template)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Template -> FilePath
name (Template -> FilePath)
-> (Template -> Template) -> Template -> (FilePath, Template)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Template -> Template
forall a. a -> a
id)
compileTemplate :: String -> Text -> Either ParseError Template
compileTemplate :: FilePath -> Text -> Either ParseError Template
compileTemplate FilePath
name' = (STree -> Template)
-> Either ParseError STree -> Either ParseError Template
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((STree -> TemplateCache -> Template)
-> TemplateCache -> STree -> Template
forall a b c. (a -> b -> c) -> b -> a -> c
flip (FilePath -> STree -> TemplateCache -> Template
Template FilePath
name') TemplateCache
forall a. Monoid a => a
mempty) (Either ParseError STree -> Either ParseError Template)
-> (Text -> Either ParseError STree)
-> Text
-> Either ParseError Template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text -> Either ParseError STree
parse FilePath
name'
getPartials :: STree -> [FilePath]
getPartials :: STree -> [FilePath]
getPartials = [[FilePath]] -> [FilePath]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join ([[FilePath]] -> [FilePath])
-> (STree -> [[FilePath]]) -> STree -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node Text -> [FilePath]) -> STree -> [[FilePath]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Node Text -> [FilePath]
getPartials'
getPartials' :: Node Text -> [FilePath]
getPartials' :: Node Text -> [FilePath]
getPartials' (Partial Maybe Text
_ FilePath
p) = FilePath -> [FilePath]
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
p
getPartials' (Section DataIdentifier
_ STree
n) = STree -> [FilePath]
getPartials STree
n
getPartials' (InvertedSection DataIdentifier
_ STree
n) = STree -> [FilePath]
getPartials STree
n
getPartials' Node Text
_ = [FilePath]
forall a. Monoid a => a
mempty
flattenPartials :: TemplateCache -> TemplateCache
flattenPartials :: TemplateCache -> TemplateCache
flattenPartials TemplateCache
m = (FilePath -> Template -> TemplateCache -> TemplateCache)
-> TemplateCache -> TemplateCache -> TemplateCache
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
foldrWithKey ((Template -> Template -> Template)
-> FilePath -> Template -> TemplateCache -> TemplateCache
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
insertWith (\Template
_ Template
b -> Template
b)) TemplateCache
m TemplateCache
m
getFile :: [FilePath] -> FilePath -> ExceptT ParseError IO Text
getFile :: [FilePath] -> FilePath -> ExceptT ParseError IO Text
getFile [] FilePath
fp = ParseError -> ExceptT ParseError IO Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ParseError -> ExceptT ParseError IO Text)
-> ParseError -> ExceptT ParseError IO Text
forall a b. (a -> b) -> a -> b
$ FilePath -> ParseError
fileNotFound FilePath
fp
getFile (FilePath
templateDir : [FilePath]
xs) FilePath
fp =
IO Bool -> ExceptT ParseError IO Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (FilePath -> IO Bool
doesFileExist FilePath
filePath) ExceptT ParseError IO Bool
-> (Bool -> ExceptT ParseError IO Text)
-> ExceptT ParseError IO Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
ExceptT ParseError IO Text
-> ExceptT ParseError IO Text -> Bool -> ExceptT ParseError IO Text
forall a. a -> a -> Bool -> a
bool
([FilePath] -> FilePath -> ExceptT ParseError IO Text
getFile [FilePath]
xs FilePath
fp)
(IO Text -> ExceptT ParseError IO Text
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Text -> ExceptT ParseError IO Text)
-> IO Text -> ExceptT ParseError IO Text
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
TIO.readFile FilePath
filePath)
where
filePath :: FilePath
filePath = FilePath
templateDir FilePath -> FilePath -> FilePath
</> FilePath
fp
mustache :: QuasiQuoter
mustache :: QuasiQuoter
mustache = QuasiQuoter :: (FilePath -> Q Exp)
-> (FilePath -> Q Pat)
-> (FilePath -> Q Type)
-> (FilePath -> Q [Dec])
-> QuasiQuoter
QuasiQuoter {quoteExp :: FilePath -> Q Exp
quoteExp = \FilePath
unprocessedTemplate -> do
Loc
l <- Q Loc
location
FilePath -> FilePath -> Q Exp
compileTemplateTH (Loc -> FilePath
fileAndLine Loc
l) FilePath
unprocessedTemplate }
embedTemplate :: [FilePath] -> FilePath -> Q Exp
embedTemplate :: [FilePath] -> FilePath -> Q Exp
embedTemplate [FilePath]
searchSpace FilePath
filename = do
Template
template <- (ParseError -> Q Template)
-> (Template -> Q Template)
-> Either ParseError Template
-> Q Template
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> Q Template
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Q Template)
-> (ParseError -> FilePath) -> ParseError -> Q Template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"Parse error in mustache template: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath)
-> (ParseError -> FilePath) -> ParseError -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> FilePath
forall a. Show a => a -> FilePath
show) Template -> Q Template
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ParseError Template -> Q Template)
-> Q (Either ParseError Template) -> Q Template
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either ParseError Template) -> Q (Either ParseError Template)
forall a. IO a -> Q a
THS.runIO ([FilePath] -> FilePath -> IO (Either ParseError Template)
automaticCompile [FilePath]
searchSpace FilePath
filename)
let possiblePaths :: [FilePath]
possiblePaths = do
FilePath
fname <- (FilePath
filenameFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:) ([FilePath] -> [FilePath])
-> (Template -> [FilePath]) -> Template -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TemplateCache -> [FilePath]
forall k v. HashMap k v -> [k]
HM.keys (TemplateCache -> [FilePath])
-> (Template -> TemplateCache) -> Template -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Template -> TemplateCache
partials (Template -> [FilePath]) -> Template -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Template
template
FilePath
path <- [FilePath]
searchSpace
FilePath -> [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> [FilePath]) -> FilePath -> [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath
path FilePath -> FilePath -> FilePath
</> FilePath
fname
(FilePath -> Q ()) -> [FilePath] -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> Q ()
addDependentRelativeFile ([FilePath] -> Q ()) -> Q [FilePath] -> Q ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [FilePath] -> Q [FilePath]
forall a. IO a -> Q a
THS.runIO ((FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
doesFileExist [FilePath]
possiblePaths)
Template -> Q Exp
forall t. Lift t => t -> Q Exp
THS.lift Template
template
embedSingleTemplate :: FilePath -> Q Exp
embedSingleTemplate :: FilePath -> Q Exp
embedSingleTemplate FilePath
filePath = do
FilePath -> Q ()
addDependentRelativeFile FilePath
filePath
FilePath -> FilePath -> Q Exp
compileTemplateTH FilePath
filePath (FilePath -> Q Exp) -> Q FilePath -> Q Exp
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath -> Q FilePath
forall a. IO a -> Q a
THS.runIO (FilePath -> IO FilePath
readFile FilePath
filePath)
fileAndLine :: Loc -> String
fileAndLine :: Loc -> FilePath
fileAndLine Loc
loc = Loc -> FilePath
loc_filename Loc
loc FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (Int -> FilePath
forall a. Show a => a -> FilePath
show (Int -> FilePath) -> (Loc -> Int) -> Loc -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Loc -> (Int, Int)) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> (Int, Int)
loc_start (Loc -> FilePath) -> Loc -> FilePath
forall a b. (a -> b) -> a -> b
$ Loc
loc)
compileTemplateTH :: String -> String -> Q Exp
compileTemplateTH :: FilePath -> FilePath -> Q Exp
compileTemplateTH FilePath
filename FilePath
unprocessed =
(ParseError -> Q Exp)
-> (Template -> Q Exp) -> Either ParseError Template -> Q Exp
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> Q Exp
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Q Exp)
-> (ParseError -> FilePath) -> ParseError -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"Parse error in mustache template: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath)
-> (ParseError -> FilePath) -> ParseError -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> FilePath
forall a. Show a => a -> FilePath
show) Template -> Q Exp
forall t. Lift t => t -> Q Exp
THS.lift (Either ParseError Template -> Q Exp)
-> Either ParseError Template -> Q Exp
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> Either ParseError Template
compileTemplate FilePath
filename (FilePath -> Text
pack FilePath
unprocessed)
addDependentRelativeFile :: FilePath -> Q ()
addDependentRelativeFile :: FilePath -> Q ()
addDependentRelativeFile = FilePath -> Q ()
forall (m :: * -> *). Quasi m => FilePath -> m ()
THS.qAddDependentFile (FilePath -> Q ()) -> (FilePath -> Q FilePath) -> FilePath -> Q ()
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO FilePath -> Q FilePath
forall a. IO a -> Q a
THS.runIO (IO FilePath -> Q FilePath)
-> (FilePath -> IO FilePath) -> FilePath -> Q FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO FilePath
makeAbsolute
fileNotFound :: FilePath -> ParseError
fileNotFound :: FilePath -> ParseError
fileNotFound FilePath
fp = Message -> SourcePos -> ParseError
newErrorMessage (FilePath -> Message
Message (FilePath -> Message) -> FilePath -> Message
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath
forall r. PrintfType r => FilePath -> r
printf FilePath
"Template file '%s' not found" FilePath
fp) (FilePath -> SourcePos
initialPos FilePath
fp)