{-# 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 :: Text -> [Node] -> Maybe FilePath -> TPath -> [Node] -> Splice n
rawApply Text
paramTag [Node]
calledNodes Maybe FilePath
templateFile TPath
newContext [Node]
paramNodes = do
    HeistState n
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
    [Node]
processedParams <- [Node] -> Splice n
forall (n :: * -> *). Monad n => [Node] -> Splice n
runNodeList [Node]
paramNodes

    -- apply should do a bottom-up traversal, so we run the called nodes
    -- before doing <content/> substitution.
    (HeistState n -> HeistState n) -> HeistT n n ()
forall (m :: * -> *) (n :: * -> *).
Monad m =>
(HeistState n -> HeistState n) -> HeistT n m ()
modifyHS (TPath -> HeistState n -> HeistState n
forall (n :: * -> *). TPath -> HeistState n -> HeistState n
setCurContext TPath
newContext (HeistState n -> HeistState n)
-> (HeistState n -> HeistState n) -> HeistState n -> HeistState n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe FilePath -> HeistState n -> HeistState n
forall (n :: * -> *).
Maybe FilePath -> HeistState n -> HeistState n
setCurTemplateFile Maybe FilePath
templateFile)

    let process :: t Node -> [Node]
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 HeistState n -> Int
forall (m :: * -> *). HeistState m -> Int
_recursionDepth HeistState n
hs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
mAX_RECURSION_DEPTH
      then do (Int -> Int) -> HeistT n n ()
forall (m :: * -> *) (n :: * -> *).
Monad m =>
(Int -> Int) -> HeistT n m ()
modRecursionDepth (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
              [Node]
res <- [Node] -> Splice n
forall (n :: * -> *). Monad n => [Node] -> Splice n
runNodeList [Node]
calledNodes
              HeistState n -> HeistT n n ()
forall (m :: * -> *) (n :: * -> *).
Monad m =>
HeistState n -> HeistT n m ()
restoreHS HeistState n
hs
              [Node] -> Splice n
forall (m :: * -> *) a. Monad m => a -> m a
return ([Node] -> Splice n) -> [Node] -> Splice n
forall a b. (a -> b) -> a -> b
$! [Node] -> [Node]
forall (t :: * -> *). Foldable t => t Node -> [Node]
process [Node]
res
      else do HeistState n -> HeistT n n ()
forall (m :: * -> *) (n :: * -> *).
Monad m =>
HeistState n -> HeistT n m ()
restoreHS HeistState n
hs
              ([Node] -> Splice n
forall (m :: * -> *) a. Monad m => a -> m a
return []) Splice n -> FilePath -> Splice n
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
HeistT n m b -> FilePath -> HeistT n m b
`orError` FilePath
err
  where
    err :: FilePath
err = FilePath
"template recursion exceeded max depth, "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
          FilePath
"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 { elementChildren :: [Node]
X.elementChildren = [Node]
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 :: [Node] -> Text -> Splice n
applyNodes [Node]
nodes Text
template = do
    HeistState n
hs <- HeistT n n (HeistState n)
forall (m :: * -> *) (n :: * -> *).
Monad m =>
HeistT n m (HeistState n)
getHS
    Splice n
-> ((DocumentFile, TPath) -> Splice n)
-> Maybe (DocumentFile, TPath)
-> Splice n
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Node] -> Splice n
forall (m :: * -> *) a. Monad m => a -> m a
return [] Splice n -> FilePath -> Splice n
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
HeistT n m b -> FilePath -> HeistT n m b
`orError` FilePath
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 FilePath -> TPath -> [Node] -> Splice n
forall (n :: * -> *).
Monad n =>
Text -> [Node] -> Maybe FilePath -> 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 FilePath
dfFile DocumentFile
t) TPath
ctx [Node]
nodes)
          (ByteString
-> HeistState n
-> (HeistState n -> HashMap TPath DocumentFile)
-> Maybe (DocumentFile, TPath)
forall (n :: * -> *) t.
ByteString
-> HeistState n
-> (HeistState n -> HashMap TPath t)
-> Maybe (t, TPath)
lookupTemplate (Text -> ByteString
T.encodeUtf8 Text
template) HeistState n
hs HeistState n -> HashMap TPath DocumentFile
forall (m :: * -> *). HeistState m -> HashMap TPath DocumentFile
_templateMap)
  where
    err :: FilePath
err = FilePath
"apply tag cannot find template \""FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++(Text -> FilePath
T.unpack Text
template)FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"\""


------------------------------------------------------------------------------
-- | Implementation of the apply splice.
applyImpl :: Monad n => Splice n
applyImpl :: Splice n
applyImpl = do
    Node
node <- HeistT n n Node
forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m Node
getParamNode
    let err :: FilePath
err = FilePath
"must supply \"" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack Text
applyAttr FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
              FilePath
"\" attribute in <" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
T.unpack (Node -> Text
X.elementTag Node
node) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
">"
    case Text -> Node -> Maybe Text
X.getAttribute Text
applyAttr Node
node of
        Maybe Text
Nothing   -> [Node] -> Splice n
forall (m :: * -> *) a. Monad m => a -> m a
return [] Splice n -> FilePath -> Splice n
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
HeistT n m b -> FilePath -> HeistT n m b
`orError` FilePath
err
        Just Text
template -> [Node] -> Text -> Splice n
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 :: Splice m
deprecatedContentCheck =
    [Node] -> Splice m
forall (m :: * -> *) a. Monad m => a -> m a
return [] Splice m -> FilePath -> Splice m
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
HeistT n m b -> FilePath -> HeistT n m b
`orError` [FilePath] -> FilePath
unwords
      [FilePath
"<content> tag deprecated.  Use"
      ,FilePath
"<apply-content> or <bind-content>"
      ]