{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Heist.Splices.Apply where

------------------------------------------------------------------------------
import           Data.Maybe
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Text.XmlHtml as X

------------------------------------------------------------------------------
import           Heist.Common
import           Heist.Interpreted.Internal
import           Heist.Internal.Types.HeistState


------------------------------------------------------------------------------
-- | Default name for the apply splice.
applyTag :: Text
applyTag :: Text
applyTag = Text
"apply"


------------------------------------------------------------------------------
-- | Default attribute name for the apply tag.
applyAttr :: Text
applyAttr :: Text
applyAttr = Text
"template"


------------------------------------------------------------------------------
-- | 
rawApply :: (Monad n)
         => Text
         -> [X.Node]
         -> Maybe FilePath
         -> TPath
         -> [X.Node]
         -> Splice n
rawApply :: forall (n :: * -> *).
Monad n =>
Text -> [Node] -> Maybe String -> TPath -> [Node] -> Splice n
rawApply Text
paramTag [Node]
calledNodes Maybe String
templateFile TPath
newContext [Node]
paramNodes = do
    hs <- HeistT n n (HeistState n)
forall (m :: * -> *) (n :: * -> *).
Monad m =>
HeistT n m (HeistState n)
getHS  -- Can't use localHS here because the modifier is not pure
    processedParams <- runNodeList paramNodes

    -- apply should do a bottom-up traversal, so we run the called nodes
    -- before doing <content/> substitution.
    modifyHS (setCurContext newContext . setCurTemplateFile templateFile)

    let process = (Node -> [Node]) -> t Node -> [Node]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Node] -> Node -> [Node]
treeMap [Node]
processedParams)
    if _recursionDepth hs < mAX_RECURSION_DEPTH
      then do modRecursionDepth (+1)
              res <- runNodeList calledNodes
              restoreHS hs
              return $! process res
      else do restoreHS hs
              (return []) `orError` err
  where
    err :: String
err = String
"template recursion exceeded max depth, "String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
"you probably have infinite splice recursion!" :: String
    treeMap :: [X.Node] -> X.Node -> [X.Node]
    treeMap :: [Node] -> Node -> [Node]
treeMap [Node]
ns n :: Node
n@(X.Element Text
nm [(Text, Text)]
_ [Node]
cs)
      | Text
nm Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
paramTag = [Node]
ns
      | Bool
otherwise = [Node
n { X.elementChildren = cs' }]
      where
        !cs' :: [Node]
cs' = (Node -> [Node]) -> [Node] -> [Node]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([Node] -> Node -> [Node]
treeMap [Node]
ns) [Node]
cs
    treeMap [Node]
_ Node
n = [Node
n]


------------------------------------------------------------------------------
-- | Applies a template as if the supplied nodes were the children of the
-- <apply> tag.
applyNodes :: Monad n => Template -> Text -> Splice n
applyNodes :: forall (n :: * -> *). Monad n => [Node] -> Text -> Splice n
applyNodes [Node]
nodes Text
template = do
    hs <- HeistT n n (HeistState n)
forall (m :: * -> *) (n :: * -> *).
Monad m =>
HeistT n m (HeistState n)
getHS
    maybe (return [] `orError` err)
          (\(DocumentFile
t,TPath
ctx) -> do
              [DocType] -> HeistT n n ()
forall (m :: * -> *) (n :: * -> *).
Monad m =>
[DocType] -> HeistT n m ()
addDoctype ([DocType] -> HeistT n n ()) -> [DocType] -> HeistT n n ()
forall a b. (a -> b) -> a -> b
$ Maybe DocType -> [DocType]
forall a. Maybe a -> [a]
maybeToList (Maybe DocType -> [DocType]) -> Maybe DocType -> [DocType]
forall a b. (a -> b) -> a -> b
$ Document -> Maybe DocType
X.docType (Document -> Maybe DocType) -> Document -> Maybe DocType
forall a b. (a -> b) -> a -> b
$ DocumentFile -> Document
dfDoc DocumentFile
t
              Text
-> [Node] -> Maybe String -> TPath -> [Node] -> HeistT n n [Node]
forall (n :: * -> *).
Monad n =>
Text -> [Node] -> Maybe String -> TPath -> [Node] -> Splice n
rawApply Text
"apply-content" (Document -> [Node]
X.docContent (Document -> [Node]) -> Document -> [Node]
forall a b. (a -> b) -> a -> b
$ DocumentFile -> Document
dfDoc DocumentFile
t)
                       (DocumentFile -> Maybe String
dfFile DocumentFile
t) TPath
ctx [Node]
nodes)
          (lookupTemplate (T.encodeUtf8 template) hs _templateMap)
  where
    err :: String
err = String
"apply tag cannot find template \""String -> String -> String
forall a. [a] -> [a] -> [a]
++(Text -> String
T.unpack Text
template)String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\""


------------------------------------------------------------------------------
-- | Implementation of the apply splice.
applyImpl :: Monad n => Splice n
applyImpl :: forall (n :: * -> *). Monad n => Splice n
applyImpl = do
    node <- HeistT n n Node
forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m Node
getParamNode
    let err = String
"must supply \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
applyAttr String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
"\" attribute in <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (Node -> Text
X.elementTag Node
node) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
    case X.getAttribute applyAttr node of
        Maybe Text
Nothing   -> [Node] -> HeistT n n [Node]
forall a. a -> HeistT n n a
forall (m :: * -> *) a. Monad m => a -> m a
return [] HeistT n n [Node] -> String -> HeistT n n [Node]
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
HeistT n m b -> String -> HeistT n m b
`orError` String
err
        Just Text
template -> [Node] -> Text -> HeistT n n [Node]
forall (n :: * -> *). Monad n => [Node] -> Text -> Splice n
applyNodes (Node -> [Node]
X.childNodes Node
node) Text
template


------------------------------------------------------------------------------
-- | This splice crashes with an error message.  Its purpose is to provide a
-- load-time warning to anyone still using the old content tag in their
-- templates.  In Heist 0.10, tho content tag was replaced by two separate
-- apply-content and bind-content tags used by the apply and bind splices
-- respectively.
deprecatedContentCheck :: Monad m => Splice m
deprecatedContentCheck :: forall (n :: * -> *). Monad n => Splice n
deprecatedContentCheck =
    [Node] -> HeistT m m [Node]
forall a. a -> HeistT m m a
forall (m :: * -> *) a. Monad m => a -> m a
return [] HeistT m m [Node] -> String -> HeistT m m [Node]
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
HeistT n m b -> String -> HeistT n m b
`orError` [String] -> String
unwords
      [String
"<content> tag deprecated.  Use"
      ,String
"<apply-content> or <bind-content>"
      ]