{-# LANGUAGE PatternGuards, DeriveDataTypeable, ScopedTypeVariables #-}

module General.Template(
    Template, templateFile, templateMarkup, templateApply, templateRender
    ) where

import Data.Data
import Data.Monoid
import Text.Blaze
import Text.Blaze.Renderer.Utf8
import General.Str
import Data.List.Extra
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

---------------------------------------------------------------------
-- TREE DATA TYPE

data Tree = Lam FilePath -- #{foo} defines a lambda
          | Var BStr -- a real variable
          | App Tree [(BStr, Tree)] -- applies a foo string to the lambda
          | Lit BStr
          | List [Tree]
            deriving (Typeable,Typeable Tree
DataType
Constr
Typeable Tree
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> Tree -> c Tree)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c Tree)
-> (Tree -> Constr)
-> (Tree -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c Tree))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Tree))
-> ((forall b. Data b => b -> b) -> Tree -> Tree)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Tree -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Tree -> r)
-> (forall u. (forall d. Data d => d -> u) -> Tree -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Tree -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Tree -> m Tree)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Tree -> m Tree)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Tree -> m Tree)
-> Data Tree
Tree -> DataType
Tree -> Constr
(forall b. Data b => b -> b) -> Tree -> Tree
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Tree -> c Tree
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Tree
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Tree -> u
forall u. (forall d. Data d => d -> u) -> Tree -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Tree -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Tree -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Tree -> m Tree
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Tree -> m Tree
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Tree
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Tree -> c Tree
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Tree)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Tree)
$cList :: Constr
$cLit :: Constr
$cApp :: Constr
$cVar :: Constr
$cLam :: Constr
$tTree :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> Tree -> m Tree
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Tree -> m Tree
gmapMp :: (forall d. Data d => d -> m d) -> Tree -> m Tree
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Tree -> m Tree
gmapM :: (forall d. Data d => d -> m d) -> Tree -> m Tree
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Tree -> m Tree
gmapQi :: Int -> (forall d. Data d => d -> u) -> Tree -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Tree -> u
gmapQ :: (forall d. Data d => d -> u) -> Tree -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Tree -> [u]
gmapQr :: (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Tree -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Tree -> r
gmapQl :: (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Tree -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Tree -> r
gmapT :: (forall b. Data b => b -> b) -> Tree -> Tree
$cgmapT :: (forall b. Data b => b -> b) -> Tree -> Tree
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Tree)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Tree)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c Tree)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Tree)
dataTypeOf :: Tree -> DataType
$cdataTypeOf :: Tree -> DataType
toConstr :: Tree -> Constr
$ctoConstr :: Tree -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Tree
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Tree
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Tree -> c Tree
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Tree -> c Tree
$cp1Data :: Typeable Tree
Data,Int -> Tree -> ShowS
[Tree] -> ShowS
Tree -> String
(Int -> Tree -> ShowS)
-> (Tree -> String) -> ([Tree] -> ShowS) -> Show Tree
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tree] -> ShowS
$cshowList :: [Tree] -> ShowS
show :: Tree -> String
$cshow :: Tree -> String
showsPrec :: Int -> Tree -> ShowS
$cshowsPrec :: Int -> Tree -> ShowS
Show)


-- | Turn all Lam into Var/Lit
treeRemoveLam :: Tree -> IO Tree
treeRemoveLam :: Tree -> IO Tree
treeRemoveLam = (Tree -> IO Tree) -> Tree -> IO Tree
forall (m :: * -> *) on.
(Monad m, Applicative m, Uniplate on) =>
(on -> m on) -> on -> m on
transformM Tree -> IO Tree
f
    where
        f :: Tree -> IO Tree
f (Lam String
file) = [Tree] -> Tree
List ([Tree] -> Tree) -> (BStr -> [Tree]) -> BStr -> Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BStr -> [Tree]
parse (BStr -> Tree) -> IO BStr -> IO Tree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO BStr
bstrReadFile String
file
        f Tree
x = Tree -> IO Tree
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tree
x

        parse :: BStr -> [Tree]
parse BStr
x | Just (BStr
a,BStr
b) <- BStr -> BStr -> Maybe (BStr, BStr)
bstrSplitInfix (String -> BStr
bstrPack String
"#{") BStr
x
                , Just (BStr
b,BStr
c) <- BStr -> BStr -> Maybe (BStr, BStr)
bstrSplitInfix (String -> BStr
bstrPack String
"}") BStr
b
                = BStr -> Tree
Lit BStr
a Tree -> [Tree] -> [Tree]
forall a. a -> [a] -> [a]
: BStr -> Tree
Var BStr
b Tree -> [Tree] -> [Tree]
forall a. a -> [a] -> [a]
: BStr -> [Tree]
parse BStr
c
        parse BStr
x = [BStr -> Tree
Lit BStr
x]

treeRemoveApp :: Tree -> Tree
treeRemoveApp :: Tree -> Tree
treeRemoveApp = [(BStr, Tree)] -> Tree -> Tree
f []
    where
        f :: [(BStr, Tree)] -> Tree -> Tree
f [(BStr, Tree)]
seen (App Tree
t [(BStr, Tree)]
xs) = [(BStr, Tree)] -> Tree -> Tree
f ([(BStr, Tree)]
xs [(BStr, Tree)] -> [(BStr, Tree)] -> [(BStr, Tree)]
forall a. [a] -> [a] -> [a]
++ [(BStr, Tree)]
seen) Tree
t
        f [(BStr, Tree)]
seen (Var BStr
x) | Just Tree
t <- BStr -> [(BStr, Tree)] -> Maybe Tree
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup BStr
x [(BStr, Tree)]
seen = [(BStr, Tree)] -> Tree -> Tree
f [(BStr, Tree)]
seen Tree
t
        f [(BStr, Tree)]
seen Tree
x = (Tree -> Tree) -> Tree -> Tree
forall on. Uniplate on => (on -> on) -> on -> on
descend ([(BStr, Tree)] -> Tree -> Tree
f [(BStr, Tree)]
seen) Tree
x

treeOptimise :: Tree -> Tree
treeOptimise :: Tree -> Tree
treeOptimise = (Tree -> Tree) -> Tree -> Tree
forall on. Uniplate on => (on -> on) -> on -> on
transform Tree -> Tree
f (Tree -> Tree) -> (Tree -> Tree) -> Tree -> Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> Tree
treeRemoveApp
    where
        fromList :: Tree -> [Tree]
fromList (List [Tree]
xs) = [Tree]
xs; fromList Tree
x = [Tree
x]
        toList :: [Tree] -> Tree
toList [Tree
x] = Tree
x; toList [Tree]
xs = [Tree] -> Tree
List [Tree]
xs
        isLit :: Tree -> Bool
isLit (Lit BStr
x) = Bool
True; isLit Tree
_ = Bool
False
        fromLit :: Tree -> BStr
fromLit (Lit BStr
x) = BStr
x

        f :: Tree -> Tree
f = [Tree] -> Tree
toList ([Tree] -> Tree) -> (Tree -> [Tree]) -> Tree -> Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tree] -> [Tree]
g ([Tree] -> [Tree]) -> (Tree -> [Tree]) -> Tree -> [Tree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree -> [Tree]) -> [Tree] -> [Tree]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree -> [Tree]
fromList ([Tree] -> [Tree]) -> (Tree -> [Tree]) -> Tree -> [Tree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> [Tree]
fromList

        g :: [Tree] -> [Tree]
g [] = []
        g (Tree
x:[Tree]
xs) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Tree -> Bool
isLit Tree
x = Tree
x Tree -> [Tree] -> [Tree]
forall a. a -> [a] -> [a]
: [Tree] -> [Tree]
g [Tree]
xs
        g [Tree]
xs = [BStr -> Tree
Lit BStr
x | let x :: BStr
x = (Tree -> BStr) -> [Tree] -> BStr
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap Tree -> BStr
fromLit [Tree]
a, BStr
x BStr -> BStr -> Bool
forall a. Eq a => a -> a -> Bool
/= BStr
forall a. Monoid a => a
mempty] [Tree] -> [Tree] -> [Tree]
forall a. [a] -> [a] -> [a]
++ [Tree] -> [Tree]
g [Tree]
b
            where ([Tree]
a,[Tree]
b) = (Tree -> Bool) -> [Tree] -> ([Tree], [Tree])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Tree -> Bool
isLit [Tree]
xs

treeEval :: Tree -> [BStr]
treeEval :: Tree -> [BStr]
treeEval = Tree -> [BStr]
f (Tree -> [BStr]) -> (Tree -> Tree) -> Tree -> [BStr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> Tree
treeRemoveApp
    where f :: Tree -> [BStr]
f (Lit BStr
x) = [BStr
x]
          f (List [Tree]
xs) = (Tree -> [BStr]) -> [Tree] -> [BStr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree -> [BStr]
f [Tree]
xs
          f Tree
_ = []


---------------------------------------------------------------------
-- TEMPLATE DATA TYPE

-- a tree, and a pre-optimised tree you can create
data Template = Template Tree (IO Tree)

{-# NOINLINE treeCache #-}
treeCache :: Tree -> IO Tree
treeCache :: Tree -> IO Tree
treeCache Tree
t0 = IO (IO Tree) -> IO Tree
forall a. IO a -> a
unsafePerformIO (IO (IO Tree) -> IO Tree) -> IO (IO Tree) -> IO Tree
forall a b. (a -> b) -> a -> b
$ do
    let files :: [String]
files = [String
x | Lam String
x <- Tree -> [Tree]
forall on. Uniplate on => on -> [on]
universe Tree
t0]
    IORef ([UTCTime], Tree)
ref <- ([UTCTime], Tree) -> IO (IORef ([UTCTime], Tree))
forall a. a -> IO (IORef a)
newIORef ([], Tree -> Tree
treeOptimise Tree
t0)
    IO Tree -> IO (IO Tree)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO Tree -> IO (IO Tree)) -> IO Tree -> IO (IO Tree)
forall a b. (a -> b) -> a -> b
$ do
        ([UTCTime]
old,Tree
t) <- IORef ([UTCTime], Tree) -> IO ([UTCTime], Tree)
forall a. IORef a -> IO a
readIORef IORef ([UTCTime], Tree)
ref
        [UTCTime]
new <- [String] -> (String -> IO UTCTime) -> IO [UTCTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
files ((String -> IO UTCTime) -> IO [UTCTime])
-> (String -> IO UTCTime) -> IO [UTCTime]
forall a b. (a -> b) -> a -> b
$ \String
file ->
            -- the standard getModificationTime message on Windows doesn't say the file
            String -> IO UTCTime
getModificationTime String
file IO UTCTime -> (IOException -> IO UTCTime) -> IO UTCTime
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) ->
                String -> IO UTCTime
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO UTCTime) -> String -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ String
"Failed: getModificationTime on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall a. Show a => a -> String
show IOException
e
        if [UTCTime]
old [UTCTime] -> [UTCTime] -> Bool
forall a. Eq a => a -> a -> Bool
== [UTCTime]
new then Tree -> IO Tree
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tree
t else do
            Tree
t <- Tree -> Tree
treeOptimise (Tree -> Tree) -> IO Tree -> IO Tree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree -> IO Tree
treeRemoveLam Tree
t0
            IORef ([UTCTime], Tree) -> ([UTCTime], Tree) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ([UTCTime], Tree)
ref ([UTCTime]
new,Tree
t)
            Tree -> IO Tree
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tree
t

templateTree :: Tree -> Template
templateTree :: Tree -> Template
templateTree Tree
t = Tree -> IO Tree -> Template
Template Tree
t (IO Tree -> Template) -> IO Tree -> Template
forall a b. (a -> b) -> a -> b
$ Tree -> IO Tree
treeCache Tree
t

templateFile :: FilePath -> Template
templateFile :: String -> Template
templateFile = Tree -> Template
templateTree (Tree -> Template) -> (String -> Tree) -> String -> Template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Tree
Lam

templateMarkup :: Markup -> Template
templateMarkup :: Markup -> Template
templateMarkup = LBStr -> Template
templateStr (LBStr -> Template) -> (Markup -> LBStr) -> Markup -> Template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> LBStr
renderMarkup

templateStr :: LBStr -> Template
templateStr :: LBStr -> Template
templateStr = Tree -> Template
templateTree (Tree -> Template) -> (LBStr -> Tree) -> LBStr -> Template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tree] -> Tree
List ([Tree] -> Tree) -> (LBStr -> [Tree]) -> LBStr -> Tree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BStr -> Tree) -> [BStr] -> [Tree]
forall a b. (a -> b) -> [a] -> [b]
map BStr -> Tree
Lit ([BStr] -> [Tree]) -> (LBStr -> [BStr]) -> LBStr -> [Tree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LBStr -> [BStr]
lbstrToChunks

templateApply :: Template -> [(String, Template)] -> Template
templateApply :: Template -> [(String, Template)] -> Template
templateApply (Template Tree
t IO Tree
_) [(String, Template)]
args = Tree -> Template
templateTree (Tree -> Template) -> Tree -> Template
forall a b. (a -> b) -> a -> b
$ Tree -> [(BStr, Tree)] -> Tree
App Tree
t [(String -> BStr
bstrPack String
a, Tree
b) | (String
a,Template Tree
b IO Tree
_) <- [(String, Template)]
args]

templateRender :: Template -> [(String, Template)] -> IO LBStr
templateRender :: Template -> [(String, Template)] -> IO LBStr
templateRender (Template Tree
_ IO Tree
t) [(String, Template)]
args = do
    Tree
t <- IO Tree
t
    let Template Tree
t2 IO Tree
_ = Template -> [(String, Template)] -> Template
templateApply (Tree -> IO Tree -> Template
Template Tree
t (IO Tree -> Template) -> IO Tree -> Template
forall a b. (a -> b) -> a -> b
$ Tree -> IO Tree
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tree
t) [(String, Template)]
args
    [BStr] -> LBStr
lbstrFromChunks ([BStr] -> LBStr) -> (Tree -> [BStr]) -> Tree -> LBStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> [BStr]
treeEval (Tree -> LBStr) -> IO Tree -> IO LBStr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tree -> IO Tree
treeRemoveLam Tree
t2