{-# 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
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 -> Constr
Tree -> DataType
(forall b. Data b => b -> b) -> Tree -> 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)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Tree -> c Tree
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Tree -> c Tree
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Tree
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Tree
$ctoConstr :: Tree -> Constr
toConstr :: Tree -> Constr
$cdataTypeOf :: Tree -> DataType
dataTypeOf :: Tree -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Tree)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Tree)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Tree)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Tree)
$cgmapT :: (forall b. Data b => b -> b) -> Tree -> Tree
gmapT :: (forall b. Data b => b -> b) -> Tree -> Tree
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Tree -> r
gmapQl :: forall r r'.
(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
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Tree -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Tree -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> Tree -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Tree -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Tree -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Tree -> m Tree
gmapM :: forall (m :: * -> *).
Monad m =>
(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
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(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
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Tree -> m Tree
Data,Int -> Tree -> ShowS
[Tree] -> ShowS
Tree -> FilePath
(Int -> Tree -> ShowS)
-> (Tree -> FilePath) -> ([Tree] -> ShowS) -> Show Tree
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tree -> ShowS
showsPrec :: Int -> Tree -> ShowS
$cshow :: Tree -> FilePath
show :: Tree -> FilePath
$cshowList :: [Tree] -> ShowS
showList :: [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 FilePath
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
<$> FilePath -> IO BStr
bstrReadFile FilePath
file
        f Tree
x = Tree -> IO Tree
forall a. a -> IO a
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 (FilePath -> BStr
bstrPack FilePath
"#{") BStr
x
                , Just (BStr
b,BStr
c) <- BStr -> BStr -> Maybe (BStr, BStr)
bstrSplitInfix (FilePath -> BStr
bstrPack FilePath
"}") 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 :: [FilePath]
files = [FilePath
x | Lam FilePath
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 a. a -> IO a
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 <- [FilePath] -> (FilePath -> IO UTCTime) -> IO [UTCTime]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
files ((FilePath -> IO UTCTime) -> IO [UTCTime])
-> (FilePath -> IO UTCTime) -> IO [UTCTime]
forall a b. (a -> b) -> a -> b
$ \FilePath
file ->
            -- the standard getModificationTime message on Windows doesn't say the file
            FilePath -> IO UTCTime
getModificationTime FilePath
file IO UTCTime -> (IOException -> IO UTCTime) -> IO UTCTime
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
e :: IOException) ->
                FilePath -> IO UTCTime
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO UTCTime) -> FilePath -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed: getModificationTime on " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
file FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
", " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ IOException -> FilePath
forall a. Show a => a -> FilePath
show IOException
e
        if [UTCTime]
old [UTCTime] -> [UTCTime] -> Bool
forall a. Eq a => a -> a -> Bool
== [UTCTime]
new then Tree -> IO Tree
forall a. a -> IO a
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 a. a -> IO a
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 :: FilePath -> Template
templateFile = Tree -> Template
templateTree (Tree -> Template) -> (FilePath -> Tree) -> FilePath -> Template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> 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 -> [(FilePath, Template)] -> Template
templateApply (Template Tree
t IO Tree
_) [(FilePath, Template)]
args = Tree -> Template
templateTree (Tree -> Template) -> Tree -> Template
forall a b. (a -> b) -> a -> b
$ Tree -> [(BStr, Tree)] -> Tree
App Tree
t [(FilePath -> BStr
bstrPack FilePath
a, Tree
b) | (FilePath
a,Template Tree
b IO Tree
_) <- [(FilePath, Template)]
args]

templateRender :: Template -> [(String, Template)] -> IO LBStr
templateRender :: Template -> [(FilePath, Template)] -> IO LBStr
templateRender (Template Tree
_ IO Tree
t) [(FilePath, Template)]
args = do
    Tree
t <- IO Tree
t
    let Template Tree
t2 IO Tree
_ = Template -> [(FilePath, 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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tree
t) [(FilePath, 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