1 module Text.Templating.Heist.Splices.Static
    2   ( StaticTagState
    3   , bindStaticTag
    4   , clearStaticTagCache
    5   ) where
    6 
    7 ------------------------------------------------------------------------------
    8 import           Control.Concurrent
    9 import           Control.Monad
   10 import           Control.Monad.Trans
   11 import           Data.IORef
   12 import qualified Data.Map as Map
   13 import           Data.Map (Map)
   14 import           Data.Maybe
   15 import qualified Data.Set as Set
   16 import           Data.Text (Text)
   17 import qualified Data.Text as T
   18 import           System.Random
   19 import           Text.XmlHtml.Cursor
   20 import           Text.XmlHtml hiding (Node)
   21 
   22 
   23 ------------------------------------------------------------------------------
   24 import           Text.Templating.Heist.Internal
   25 import           Text.Templating.Heist.Types
   26 
   27 
   28 ------------------------------------------------------------------------------
   29 -- | State for storing static tag information
   30 newtype StaticTagState = STS (MVar (Map Text Template))
   31 
   32 
   33 ------------------------------------------------------------------------------
   34 -- | Clears the static tag state.
   35 clearStaticTagCache :: StaticTagState -> IO ()
   36 clearStaticTagCache (STS staticMVar) =
   37     modifyMVar_ staticMVar (const $ return Map.empty)
   38 
   39 
   40 ------------------------------------------------------------------------------
   41 -- | The \"static\" splice ensures that its contents are evaluated once and
   42 -- then cached.  The cached contents are returned every time the splice is
   43 -- referenced.
   44 staticImpl :: (MonadIO m)
   45            => StaticTagState
   46            -> HeistT m Template
   47 staticImpl (STS mv) = do
   48     tree <- getParamNode
   49     let i = fromJust $ getAttribute "id" tree
   50 
   51     mp <- liftIO $ readMVar mv
   52 
   53     (mp',ns) <- do
   54                    let mbn = Map.lookup i mp
   55                    case mbn of
   56                        Nothing -> do
   57                            nodes' <- runNodeList $ childNodes tree
   58                            return $! (Map.insert i nodes' mp, nodes')
   59                        (Just n) -> do
   60                            stopRecursion
   61                            return $! (mp,n)
   62 
   63     liftIO $ modifyMVar_ mv (const $ return mp')
   64 
   65     return ns
   66 
   67 
   68 ------------------------------------------------------------------------------
   69 -- | Modifies a TemplateState to include a \"static\" tag.  The static tag is
   70 -- not bound automatically with the other default Heist tags.  This is because
   71 -- this function also returns StaticTagState, so the user will be able to
   72 -- clear it with the 'clearStaticTagCache' function.
   73 bindStaticTag :: MonadIO m
   74               => TemplateState m
   75               -> IO (TemplateState m, StaticTagState)
   76 bindStaticTag ts = do
   77     sr <- newIORef $ Set.empty
   78     mv <- liftM STS $ newMVar Map.empty
   79 
   80     return $ (addOnLoadHook (assignIds sr) $
   81                 bindSplice "static" (staticImpl mv) ts,
   82               mv)
   83 
   84   where
   85     generateId :: IO Int
   86     generateId = getStdRandom random
   87 
   88     assignIds setref = mapM f
   89         where
   90           f node = g $ fromNode node
   91 
   92           getId = do
   93               i  <- liftM (T.pack . show) generateId
   94               st <- readIORef setref
   95               if Set.member i st
   96                 then getId
   97                 else do
   98                     writeIORef setref $ Set.insert i st
   99                     return i
  100 
  101           g curs = do
  102               let node = current curs
  103               curs' <- if tagName node == Just "static"
  104                          then do
  105                              i <- getId
  106                              return $ modifyNode (setAttribute "id" i) curs
  107                          else return curs
  108               let mbc = nextDF curs'
  109               maybe (return $ topNode curs') g mbc
  110 
  111 
  112 
  113