{-# LANGUAGE PatternGuards, DeriveDataTypeable, ScopedTypeVariables #-}
module General.Template(
Template, templateFile, templateStr, templateApply, templateRender
) where
import Data.Data
import Data.Monoid
import General.Str
import Control.Exception
import Data.Generics.Uniplate.Data
import Control.Applicative
import System.IO.Unsafe
import System.Directory
import Control.Monad
import Data.IORef
import Prelude
data Tree = Lam FilePath
| Var Str
| App Tree [(Str, Tree)]
| Lit Str
| List [Tree]
deriving (Typeable,Data,Show)
treeRemoveLam :: Tree -> IO Tree
treeRemoveLam = transformM f
where
f (Lam file) = List . parse <$> strReadFile file
f x = return x
parse x | Just (a,b) <- strSplitInfix (strPack "#{") x
, Just (b,c) <- strSplitInfix (strPack "}") b
= Lit a : Var b : parse c
parse x = [Lit x]
treeRemoveApp :: Tree -> Tree
treeRemoveApp = f []
where
f seen (App t xs) = f (xs ++ seen) t
f seen (Var x) | Just t <- lookup x seen = f seen t
f seen x = descend (f seen) x
treeOptimise :: Tree -> Tree
treeOptimise = transform f . treeRemoveApp
where
fromList (List xs) = xs; fromList x = [x]
toList [x] = x; toList xs = List xs
isLit (Lit x) = True; isLit _ = False
fromLit (Lit x) = x
f = toList . g . concatMap fromList . fromList
g [] = []
g (x:xs) | not $ isLit x = x : g xs
g xs = [Lit x | let x = mconcat $ map fromLit a, x /= mempty] ++ g b
where (a,b) = span isLit xs
treeEval :: Tree -> [Str]
treeEval = f . treeRemoveApp
where f (Lit x) = [x]
f (List xs) = concatMap f xs
f _ = []
data Template = Template Tree (IO Tree)
{-# NOINLINE treeCache #-}
treeCache :: Tree -> IO Tree
treeCache t0 = unsafePerformIO $ do
let files = [x | Lam x <- universe t0]
ref <- newIORef ([], treeOptimise t0)
return $ do
(old,t) <- readIORef ref
new <- forM files $ \file ->
getModificationTime file `catch` \(e :: IOException) ->
fail $ "Failed: getModificationTime on " ++ file ++ ", " ++ show e
if old == new then return t else do
t <- treeOptimise <$> treeRemoveLam t0
writeIORef ref (new,t)
return t
templateTree :: Tree -> Template
templateTree t = Template t $ treeCache t
templateFile :: FilePath -> Template
templateFile = templateTree . Lam
templateStr :: LStr -> Template
templateStr = templateTree . List . map Lit . lstrToChunks
templateApply :: Template -> [(String, Template)] -> Template
templateApply (Template t _) args = templateTree $ App t [(strPack a, b) | (a,Template b _) <- args]
templateRender :: Template -> [(String, Template)] -> IO LStr
templateRender (Template _ t) args = do
t <- t
let Template t2 _ = templateApply (Template t $ return t) args
lstrFromChunks . treeEval <$> treeRemoveLam t2