module Text.Templating.Heist.Splices.Static
( StaticTagState
, bindStaticTag
, clearStaticTagCache
) where
import Control.Concurrent
import Control.Monad
import Control.Monad.Trans
import Data.IORef
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import System.Random
import Text.XmlHtml.Cursor
import Text.XmlHtml hiding (Node)
import Text.Templating.Heist.Internal
import Text.Templating.Heist.Types
newtype StaticTagState = STS (MVar (Map Text Template))
clearStaticTagCache :: StaticTagState -> IO ()
clearStaticTagCache (STS staticMVar) =
modifyMVar_ staticMVar (const $ return Map.empty)
staticImpl :: (MonadIO m)
=> StaticTagState
-> TemplateMonad m Template
staticImpl (STS mv) = do
tree <- getParamNode
let i = fromJust $ getAttribute "id" tree
mp <- liftIO $ readMVar mv
(mp',ns) <- do
let mbn = Map.lookup i mp
case mbn of
Nothing -> do
nodes' <- runNodeList $ childNodes tree
return $! (Map.insert i nodes' mp, nodes')
(Just n) -> do
stopRecursion
return $! (mp,n)
liftIO $ modifyMVar_ mv (const $ return mp')
return ns
bindStaticTag :: MonadIO m
=> TemplateState m
-> IO (TemplateState m, StaticTagState)
bindStaticTag ts = do
sr <- newIORef $ Set.empty
mv <- liftM STS $ newMVar Map.empty
return $ (addOnLoadHook (assignIds sr) $
bindSplice "static" (staticImpl mv) ts,
mv)
where
generateId :: IO Int
generateId = getStdRandom random
assignIds setref = mapM f
where
f node = g $ fromNode node
getId = do
i <- liftM (T.pack . show) generateId
st <- readIORef setref
if Set.member i st
then getId
else do
writeIORef setref $ Set.insert i st
return i
g curs = do
let node = current curs
curs' <- if tagName node == Just "static"
then do
i <- getId
return $ modifyNode (setAttribute "id" i) curs
else return curs
let mbc = nextDF curs'
maybe (return $ topNode curs') g mbc