{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Heist.Common where

------------------------------------------------------------------------------
import           Control.Applicative      (Alternative (..))
import           Control.Exception        (SomeException)
import qualified Control.Exception.Lifted as C
import           Control.Monad            (liftM, mplus)
import qualified Data.Attoparsec.Text     as AP
import           Data.ByteString          (ByteString)
import qualified Data.ByteString          as B
import qualified Data.ByteString.Char8    as BC
import           Data.Hashable            (Hashable)
import           Data.HashMap.Strict      (HashMap)
import qualified Data.HashMap.Strict      as Map
import           Data.List                (isSuffixOf, sort)
import           Data.Map.Syntax
import           Data.Maybe               (isJust)
import           Data.Monoid              ((<>))
import           Data.Text                (Text)
import qualified Data.Text                as T
import           Heist.Internal.Types.HeistState
import           System.FilePath          (pathSeparator)
import qualified Text.XmlHtml             as X
#if !MIN_VERSION_base(4,8,0)
import           Control.Applicative      (Applicative (..), (<$>))
import           Data.Monoid              (Monoid (..))
#endif
------------------------------------------------------------------------------


------------------------------------------------------------------------------
runHashMap
    :: Splices s
    -> Either [String] (HashMap T.Text s)
runHashMap :: Splices s -> Either [String] (HashMap Text s)
runHashMap Splices s
ms =
    case (Text -> HashMap Text s -> Maybe s)
-> (Text -> s -> HashMap Text s -> HashMap Text s)
-> Splices s
-> Either [Text] (HashMap Text s)
forall map k v a.
Monoid map =>
(k -> map -> Maybe v)
-> (k -> v -> map -> map) -> MapSyntaxM k v a -> Either [k] map
runMapSyntax Text -> HashMap Text s -> Maybe s
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Text -> s -> HashMap Text s -> HashMap Text s
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert Splices s
ms of
      Left [Text]
keys -> [String] -> Either [String] (HashMap Text s)
forall a b. a -> Either a b
Left ([String] -> Either [String] (HashMap Text s))
-> [String] -> Either [String] (HashMap Text s)
forall a b. (a -> b) -> a -> b
$ (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
forall a. (Semigroup a, IsString a) => a -> a
mkMsg) [Text]
keys
      Right HashMap Text s
hm -> HashMap Text s -> Either [String] (HashMap Text s)
forall a b. b -> Either a b
Right HashMap Text s
hm
  where
    mkMsg :: a -> a
mkMsg a
k = a
"You tried to bind "a -> a -> a
forall a. Semigroup a => a -> a -> a
<>a
ka -> a -> a
forall a. Semigroup a => a -> a -> a
<>a
" more than once!"


------------------------------------------------------------------------------
runMapNoErrors :: (Eq k, Hashable k) => MapSyntaxM k v a -> HashMap k v
runMapNoErrors :: MapSyntaxM k v a -> HashMap k v
runMapNoErrors = ([k] -> HashMap k v)
-> (HashMap k v -> HashMap k v)
-> Either [k] (HashMap k v)
-> HashMap k v
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (HashMap k v -> [k] -> HashMap k v
forall a b. a -> b -> a
const HashMap k v
forall a. Monoid a => a
mempty) HashMap k v -> HashMap k v
forall a. a -> a
id (Either [k] (HashMap k v) -> HashMap k v)
-> (MapSyntaxM k v a -> Either [k] (HashMap k v))
-> MapSyntaxM k v a
-> HashMap k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (k -> v -> v -> Maybe v)
-> (k -> HashMap k v -> Maybe v)
-> (k -> v -> HashMap k v -> HashMap k v)
-> MapSyntaxM k v a
-> Either [k] (HashMap k v)
forall map k v a.
Monoid map =>
(k -> v -> v -> Maybe v)
-> (k -> map -> Maybe v)
-> (k -> v -> map -> map)
-> MapSyntaxM k v a
-> Either [k] map
runMapSyntax' (\k
_ v
new v
_ -> v -> Maybe v
forall a. a -> Maybe a
Just v
new) k -> HashMap k v -> Maybe v
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup k -> v -> HashMap k v -> HashMap k v
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert

applySpliceMap :: HeistState n
                -> (HeistState n -> HashMap Text v)
                -> MapSyntaxM Text v a
                -> HashMap Text v
applySpliceMap :: HeistState n
-> (HeistState n -> HashMap Text v)
-> MapSyntaxM Text v a
-> HashMap Text v
applySpliceMap HeistState n
hs HeistState n -> HashMap Text v
f =  ((HashMap Text v -> HashMap Text v -> HashMap Text v)
-> HashMap Text v -> HashMap Text v -> HashMap Text v
forall a b c. (a -> b -> c) -> b -> a -> c
flip HashMap Text v -> HashMap Text v -> HashMap Text v
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
Map.union (HeistState n -> HashMap Text v
f HeistState n
hs)) (HashMap Text v -> HashMap Text v)
-> (MapSyntaxM Text v a -> HashMap Text v)
-> MapSyntaxM Text v a
-> HashMap Text v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    MapSyntaxM Text v () -> HashMap Text v
forall k v a. (Eq k, Hashable k) => MapSyntaxM k v a -> HashMap k v
runMapNoErrors (MapSyntaxM Text v () -> HashMap Text v)
-> (MapSyntaxM Text v a -> MapSyntaxM Text v ())
-> MapSyntaxM Text v a
-> HashMap Text v
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (Text -> Text) -> MapSyntaxM Text v a -> MapSyntaxM Text v ()
forall k1 k2 v a. (k1 -> k2) -> MapSyntaxM k1 v a -> MapSyntax k2 v
mapK (Text -> Text -> Text
forall a. Monoid a => a -> a -> a
mappend Text
pre)
  where
    pre :: Text
pre = HeistState n -> Text
forall (m :: * -> *). HeistState m -> Text
_splicePrefix HeistState n
hs

------------------------------------------------------------------------------
-- | If Heist is running in fail fast mode, then this function will throw an
-- exception with the second argument as the error message.  Otherwise, the
-- first argument will be executed to represent silent failure.
--
-- This behavior allows us to fail quickly if an error crops up during
-- load-time splice processing or degrade more gracefully if the error occurs
-- while a user request is being processed.
orError :: Monad m => HeistT n m b -> String -> HeistT n m b
orError :: HeistT n m b -> String -> HeistT n m b
orError HeistT n m b
silent String
msg = do
    HeistState n
hs <- HeistT n m (HeistState n)
forall (m :: * -> *) (n :: * -> *).
Monad m =>
HeistT n m (HeistState n)
getHS
    if HeistState n -> Bool
forall (m :: * -> *). HeistState m -> Bool
_preprocessingMode HeistState n
hs
      then do Text
fullMsg <- Text -> HeistT n m Text
forall (m :: * -> *) (n :: * -> *).
Monad m =>
Text -> HeistT n m Text
heistErrMsg (String -> Text
T.pack String
msg)
              String -> HeistT n m b
forall a. HasCallStack => String -> a
error (String -> HeistT n m b) -> String -> HeistT n m b
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
fullMsg
      else HeistT n m b
silent


------------------------------------------------------------------------------
-- | Prepends the location of the template currently being processed to an
-- error message.
heistErrMsg :: Monad m => Text -> HeistT n m Text
heistErrMsg :: Text -> HeistT n m Text
heistErrMsg Text
msg = do
    Maybe String
tf <- (HeistState n -> Maybe String) -> HeistT n m (Maybe String)
forall (m :: * -> *) (n :: * -> *) r.
Monad m =>
(HeistState n -> r) -> HeistT n m r
getsHS HeistState n -> Maybe String
forall (m :: * -> *). HeistState m -> Maybe String
_curTemplateFile
    Text -> HeistT n m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> HeistT n m Text) -> Text -> HeistT n m Text
forall a b. (a -> b) -> a -> b
$ (Text -> (String -> Text) -> Maybe String -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
": ") (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack) Maybe String
tf) Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
msg


------------------------------------------------------------------------------
-- | Adds an error message to the list of splice processing errors.
tellSpliceError :: Monad m => Text -> HeistT n m ()
tellSpliceError :: Text -> HeistT n m ()
tellSpliceError Text
msg = do
    HeistState n
hs <- HeistT n m (HeistState n)
forall (m :: * -> *) (n :: * -> *).
Monad m =>
HeistT n m (HeistState n)
getHS
    Node
node <- HeistT n m Node
forall (m :: * -> *) (n :: * -> *). Monad m => HeistT n m Node
getParamNode
    let spliceError :: SpliceError
spliceError = SpliceError :: [(TPath, Maybe String, Text)]
-> Maybe String -> [Text] -> Node -> Text -> SpliceError
SpliceError
                      { spliceHistory :: [(TPath, Maybe String, Text)]
spliceHistory = HeistState n -> [(TPath, Maybe String, Text)]
forall (m :: * -> *). HeistState m -> [(TPath, Maybe String, Text)]
_splicePath HeistState n
hs
                      , spliceTemplateFile :: Maybe String
spliceTemplateFile = HeistState n -> Maybe String
forall (m :: * -> *). HeistState m -> Maybe String
_curTemplateFile HeistState n
hs
                      , visibleSplices :: [Text]
visibleSplices = [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HashMap Text (HeistT n IO (DList (Chunk n))) -> [Text]
forall k v. HashMap k v -> [k]
Map.keys (HashMap Text (HeistT n IO (DList (Chunk n))) -> [Text])
-> HashMap Text (HeistT n IO (DList (Chunk n))) -> [Text]
forall a b. (a -> b) -> a -> b
$ HeistState n -> HashMap Text (HeistT n IO (DList (Chunk n)))
forall (m :: * -> *).
HeistState m -> HashMap Text (HeistT m IO (DList (Chunk m)))
_compiledSpliceMap HeistState n
hs
                      , contextNode :: Node
contextNode = Node
node
                      , spliceMsg :: Text
spliceMsg = Text
msg
                      }
    (HeistState n -> HeistState n) -> HeistT n m ()
forall (m :: * -> *) (n :: * -> *).
Monad m =>
(HeistState n -> HeistState n) -> HeistT n m ()
modifyHS (\HeistState n
hs' -> HeistState n
hs { _spliceErrors :: [SpliceError]
_spliceErrors = SpliceError
spliceError SpliceError -> [SpliceError] -> [SpliceError]
forall a. a -> [a] -> [a]
: HeistState n -> [SpliceError]
forall (m :: * -> *). HeistState m -> [SpliceError]
_spliceErrors HeistState n
hs' })


------------------------------------------------------------------------------
-- | Function for showing a TPath.
showTPath :: TPath -> String
showTPath :: TPath -> String
showTPath = ByteString -> String
BC.unpack (ByteString -> String) -> (TPath -> ByteString) -> TPath -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString -> ByteString
`BC.append` ByteString
".tpl") (ByteString -> ByteString)
-> (TPath -> ByteString) -> TPath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TPath -> ByteString
tpathName


------------------------------------------------------------------------------
-- | Convert a TPath into a ByteString path.
tpathName :: TPath -> ByteString
tpathName :: TPath -> ByteString
tpathName = ByteString -> TPath -> ByteString
BC.intercalate ByteString
"/" (TPath -> ByteString) -> (TPath -> TPath) -> TPath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TPath -> TPath
forall a. [a] -> [a]
reverse


------------------------------------------------------------------------------
-- | Sets the current template file.
setCurTemplateFile :: Maybe FilePath -> HeistState n -> HeistState n
setCurTemplateFile :: Maybe String -> HeistState n -> HeistState n
setCurTemplateFile Maybe String
Nothing HeistState n
ts = HeistState n
ts
setCurTemplateFile Maybe String
fp HeistState n
ts = HeistState n
ts { _curTemplateFile :: Maybe String
_curTemplateFile = Maybe String
fp }


------------------------------------------------------------------------------
setCurContext :: TPath -> HeistState n -> HeistState n
setCurContext :: TPath -> HeistState n -> HeistState n
setCurContext TPath
tp HeistState n
ts = HeistState n
ts { _curContext :: TPath
_curContext = TPath
tp }


------------------------------------------------------------------------------
-- | Parser for attribute variable substitution.
attParser :: AP.Parser [AttAST]
attParser :: Parser [AttAST]
attParser = (([AttAST] -> [AttAST]) -> [AttAST])
-> Parser Text ([AttAST] -> [AttAST]) -> Parser [AttAST]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (([AttAST] -> [AttAST]) -> [AttAST] -> [AttAST]
forall a b. (a -> b) -> a -> b
$! []) (([AttAST] -> [AttAST]) -> Parser Text ([AttAST] -> [AttAST])
forall c. ([AttAST] -> c) -> Parser Text ([AttAST] -> c)
loop [AttAST] -> [AttAST]
forall a. a -> a
id)
  where
    append :: ([a] -> c) -> a -> [a] -> c
append ![a] -> c
dl !a
x = [a] -> c
dl ([a] -> c) -> ([a] -> [a]) -> [a] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:)

    loop :: ([AttAST] -> c) -> Parser Text ([AttAST] -> c)
loop ![AttAST] -> c
dl = ([Text] -> [Text]) -> Parser Text ([AttAST] -> c)
go [Text] -> [Text]
forall a. a -> a
id
      where
        finish :: ([a] -> [Text]) -> m ([AttAST] -> c)
finish [a] -> [Text]
subDL = let !txt :: Text
txt = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$! [a] -> [Text]
subDL []
                           lit :: AttAST
lit  = Text -> AttAST
Literal (Text -> AttAST) -> Text -> AttAST
forall a b. (a -> b) -> a -> b
$! [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$! [a] -> [Text]
subDL []
                       in ([AttAST] -> c) -> m ([AttAST] -> c)
forall (m :: * -> *) a. Monad m => a -> m a
return (([AttAST] -> c) -> m ([AttAST] -> c))
-> ([AttAST] -> c) -> m ([AttAST] -> c)
forall a b. (a -> b) -> a -> b
$! if Text -> Bool
T.null Text
txt
                                      then [AttAST] -> c
dl
                                      else ([AttAST] -> c) -> AttAST -> [AttAST] -> c
forall a c. ([a] -> c) -> a -> [a] -> c
append [AttAST] -> c
dl AttAST
lit

        go :: ([Text] -> [Text]) -> Parser Text ([AttAST] -> c)
go ![Text] -> [Text]
subDL = (Parser Text
gobbleText Parser Text
-> (Text -> Parser Text ([AttAST] -> c))
-> Parser Text ([AttAST] -> c)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Text] -> [Text]) -> Parser Text ([AttAST] -> c)
go (([Text] -> [Text]) -> Parser Text ([AttAST] -> c))
-> (Text -> [Text] -> [Text])
-> Text
-> Parser Text ([AttAST] -> c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> [Text]) -> Text -> [Text] -> [Text]
forall a c. ([a] -> c) -> a -> [a] -> c
append [Text] -> [Text]
subDL)
                    Parser Text ([AttAST] -> c)
-> Parser Text ([AttAST] -> c) -> Parser Text ([AttAST] -> c)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser Text ()
forall t. Chunk t => Parser t ()
AP.endOfInput Parser Text ()
-> Parser Text ([AttAST] -> c) -> Parser Text ([AttAST] -> c)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([Text] -> [Text]) -> Parser Text ([AttAST] -> c)
forall (m :: * -> *) a.
Monad m =>
([a] -> [Text]) -> m ([AttAST] -> c)
finish [Text] -> [Text]
subDL)
                    Parser Text ([AttAST] -> c)
-> Parser Text ([AttAST] -> c) -> Parser Text ([AttAST] -> c)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (do
                            AttAST
idp <- Parser Text AttAST
identParser
                            [AttAST] -> c
dl' <- ([Text] -> [Text]) -> Parser Text ([AttAST] -> c)
forall (m :: * -> *) a.
Monad m =>
([a] -> [Text]) -> m ([AttAST] -> c)
finish [Text] -> [Text]
subDL
                            ([AttAST] -> c) -> Parser Text ([AttAST] -> c)
loop (([AttAST] -> c) -> Parser Text ([AttAST] -> c))
-> ([AttAST] -> c) -> Parser Text ([AttAST] -> c)
forall a b. (a -> b) -> a -> b
$! ([AttAST] -> c) -> AttAST -> [AttAST] -> c
forall a c. ([a] -> c) -> a -> [a] -> c
append [AttAST] -> c
dl' AttAST
idp)

    gobbleText :: Parser Text
gobbleText = (Char -> Bool) -> Parser Text
AP.takeWhile1 (String -> Char -> Bool
AP.notInClass String
"$")

    identParser :: Parser Text AttAST
identParser = Char -> Parser Char
AP.char Char
'$' Parser Char -> Parser Text AttAST -> Parser Text AttAST
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser Text AttAST
ident Parser Text AttAST -> Parser Text AttAST -> Parser Text AttAST
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> AttAST -> Parser Text AttAST
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> AttAST
Literal Text
"$"))
    ident :: Parser Text AttAST
ident = (Char -> Parser Char
AP.char Char
'{' Parser Char -> Parser Text AttAST -> Parser Text AttAST
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> AttAST
Ident (Text -> AttAST) -> Parser Text -> Parser Text AttAST
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Bool) -> Parser Text
AP.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'}')) Parser Text AttAST -> Parser Text -> Parser Text AttAST
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> Parser Text
AP.string Text
"}")


------------------------------------------------------------------------------
-- | Converts a path into an array of the elements in reverse order.  If the
-- path is absolute, we need to remove the leading slash so the split doesn't
-- leave @\"\"@ as the last element of the TPath.
--
-- FIXME @\"..\"@ currently doesn't work in paths, the solution is non-trivial
splitPathWith :: Char -> ByteString -> TPath
splitPathWith :: Char -> ByteString -> TPath
splitPathWith Char
s ByteString
p = if ByteString -> Bool
BC.null ByteString
p then [] else (TPath -> TPath
forall a. [a] -> [a]
reverse (TPath -> TPath) -> TPath -> TPath
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> TPath
BC.split Char
s ByteString
path)
  where
    path :: ByteString
path = if ByteString -> Char
BC.head ByteString
p Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
s then ByteString -> ByteString
BC.tail ByteString
p else ByteString
p


------------------------------------------------------------------------------
-- | Converts a path into an array of the elements in reverse order using the
-- path separator of the local operating system. See 'splitPathWith' for more
-- details.
splitLocalPath :: ByteString -> TPath
splitLocalPath :: ByteString -> TPath
splitLocalPath = Char -> ByteString -> TPath
splitPathWith Char
pathSeparator


------------------------------------------------------------------------------
-- | Converts a path into an array of the elements in reverse order using a
-- forward slash (/) as the path separator. See 'splitPathWith' for more
-- details.
splitTemplatePath :: ByteString -> TPath
splitTemplatePath :: ByteString -> TPath
splitTemplatePath = Char -> ByteString -> TPath
splitPathWith Char
'/'


------------------------------------------------------------------------------
-- | Convenience function for looking up a template.
lookupTemplate :: ByteString
               -> HeistState n
               -> (HeistState n -> HashMap TPath t)
               -> Maybe (t, TPath)
lookupTemplate :: ByteString
-> HeistState n
-> (HeistState n -> HashMap TPath t)
-> Maybe (t, TPath)
lookupTemplate ByteString
nameStr HeistState n
ts HeistState n -> HashMap TPath t
tm = HashMap TPath t -> TPath -> ByteString -> Maybe (t, TPath)
forall a t.
(Eq a, Hashable a) =>
HashMap [a] t -> [a] -> a -> Maybe (t, [a])
f (HeistState n -> HashMap TPath t
tm HeistState n
ts) TPath
path ByteString
name
  where
    (ByteString
name:TPath
p) = case ByteString -> TPath
splitTemplatePath ByteString
nameStr of
                   [] -> [ByteString
""]
                   TPath
ps -> TPath
ps
    ctx :: TPath
ctx = if ByteString -> ByteString -> Bool
B.isPrefixOf ByteString
"/" ByteString
nameStr then [] else HeistState n -> TPath
forall (m :: * -> *). HeistState m -> TPath
_curContext HeistState n
ts
    path :: TPath
path = TPath
p TPath -> TPath -> TPath
forall a. [a] -> [a] -> [a]
++ TPath
ctx
    f :: HashMap [a] t -> [a] -> a -> Maybe (t, [a])
f = if Char
'/' Char -> ByteString -> Bool
`BC.elem` ByteString
nameStr
            then HashMap [a] t -> [a] -> a -> Maybe (t, [a])
forall a t.
(Eq a, Hashable a) =>
HashMap [a] t -> [a] -> a -> Maybe (t, [a])
singleLookup
            else HashMap [a] t -> [a] -> a -> Maybe (t, [a])
forall a t.
(Eq a, Hashable a) =>
HashMap [a] t -> [a] -> a -> Maybe (t, [a])
traversePath


------------------------------------------------------------------------------
-- | Returns 'True' if the given template can be found in the heist state.
hasTemplate :: ByteString -> HeistState n -> Bool
hasTemplate :: ByteString -> HeistState n -> Bool
hasTemplate ByteString
nameStr HeistState n
ts =
    Maybe (DocumentFile, TPath) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (DocumentFile, TPath) -> Bool)
-> Maybe (DocumentFile, TPath) -> Bool
forall a b. (a -> b) -> a -> b
$ 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 ByteString
nameStr HeistState n
ts HeistState n -> HashMap TPath DocumentFile
forall (m :: * -> *). HeistState m -> HashMap TPath DocumentFile
_templateMap


------------------------------------------------------------------------------
-- | Does a single template lookup without cascading up.
singleLookup :: (Eq a, Hashable a)
             => HashMap [a] t -> [a] -> a -> Maybe (t, [a])
singleLookup :: HashMap [a] t -> [a] -> a -> Maybe (t, [a])
singleLookup HashMap [a] t
tm [a]
path a
name = (t -> (t, [a])) -> Maybe t -> Maybe (t, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\t
a -> (t
a,[a]
path)) (Maybe t -> Maybe (t, [a])) -> Maybe t -> Maybe (t, [a])
forall a b. (a -> b) -> a -> b
$ [a] -> HashMap [a] t -> Maybe t
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup (a
namea -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
path) HashMap [a] t
tm


------------------------------------------------------------------------------
-- | Searches for a template by looking in the full path then backing up into
-- each of the parent directories until the template is found.
traversePath :: (Eq a, Hashable a)
             => HashMap [a] t -> [a] -> a -> Maybe (t, [a])
traversePath :: HashMap [a] t -> [a] -> a -> Maybe (t, [a])
traversePath HashMap [a] t
tm [] a
name = (t -> (t, [a])) -> Maybe t -> Maybe (t, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\t
a -> (t
a,[])) ([a] -> HashMap [a] t -> Maybe t
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup [a
name] HashMap [a] t
tm)
traversePath HashMap [a] t
tm [a]
path a
name =
    HashMap [a] t -> [a] -> a -> Maybe (t, [a])
forall a t.
(Eq a, Hashable a) =>
HashMap [a] t -> [a] -> a -> Maybe (t, [a])
singleLookup HashMap [a] t
tm [a]
path a
name Maybe (t, [a]) -> Maybe (t, [a]) -> Maybe (t, [a])
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus`
    HashMap [a] t -> [a] -> a -> Maybe (t, [a])
forall a t.
(Eq a, Hashable a) =>
HashMap [a] t -> [a] -> a -> Maybe (t, [a])
traversePath HashMap [a] t
tm ([a] -> [a]
forall a. [a] -> [a]
tail [a]
path) a
name


------------------------------------------------------------------------------
-- | Maps a splice generating function over a list and concatenates the
-- results.  This function now has a more general type signature so it works
-- with both compiled and interpreted splices.  The old type signature was
-- this:
--
-- > mapSplices :: (Monad n)
-- >         => (a -> Splice n n)
-- >         -> [a]
-- >         -> Splice n n
mapSplices :: (Monad m, Monoid b)
           => (a -> m b)
           -- ^ Splice generating function
           -> [a]
           -- ^ List of items to generate splices for
           -> m b
           -- ^ The result of all splices concatenated together.
mapSplices :: (a -> m b) -> [a] -> m b
mapSplices a -> m b
f [a]
vs = ([b] -> b) -> m [b] -> m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [b] -> b
forall a. Monoid a => [a] -> a
mconcat (m [b] -> m b) -> m [b] -> m b
forall a b. (a -> b) -> a -> b
$ (a -> m b) -> [a] -> m [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> m b
f [a]
vs
{-# INLINE mapSplices #-}


------------------------------------------------------------------------------
-- | Gets the current context
getContext :: Monad m => HeistT n m TPath
getContext :: HeistT n m TPath
getContext = (HeistState n -> TPath) -> HeistT n m TPath
forall (m :: * -> *) (n :: * -> *) r.
Monad m =>
(HeistState n -> r) -> HeistT n m r
getsHS HeistState n -> TPath
forall (m :: * -> *). HeistState m -> TPath
_curContext


------------------------------------------------------------------------------
-- | Gets the full path to the file holding the template currently being
-- processed.  Returns Nothing if the template is not associated with a file
-- on disk or if there is no template being processed.
getTemplateFilePath :: Monad m => HeistT n m (Maybe FilePath)
getTemplateFilePath :: HeistT n m (Maybe String)
getTemplateFilePath = (HeistState n -> Maybe String) -> HeistT n m (Maybe String)
forall (m :: * -> *) (n :: * -> *) r.
Monad m =>
(HeistState n -> r) -> HeistT n m r
getsHS HeistState n -> Maybe String
forall (m :: * -> *). HeistState m -> Maybe String
_curTemplateFile


------------------------------------------------------------------------------
-- | Loads a template with the specified path and filename.  The
-- template is only loaded if it has a ".tpl" or ".xtpl" extension.
loadTemplate :: String -- ^ path of the template root
             -> String -- ^ full file path (includes the template root)
             -> IO [Either String (TPath, DocumentFile)] --TemplateMap
loadTemplate :: String -> String -> IO [Either String (TPath, DocumentFile)]
loadTemplate String
templateRoot String
fname = do
    [Either String DocumentFile]
c <- String -> IO [Either String DocumentFile]
loadTemplate' String
fname
    [Either String (TPath, DocumentFile)]
-> IO [Either String (TPath, DocumentFile)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either String (TPath, DocumentFile)]
 -> IO [Either String (TPath, DocumentFile)])
-> [Either String (TPath, DocumentFile)]
-> IO [Either String (TPath, DocumentFile)]
forall a b. (a -> b) -> a -> b
$ (Either String DocumentFile -> Either String (TPath, DocumentFile))
-> [Either String DocumentFile]
-> [Either String (TPath, DocumentFile)]
forall a b. (a -> b) -> [a] -> [b]
map ((DocumentFile -> (TPath, DocumentFile))
-> Either String DocumentFile
-> Either String (TPath, DocumentFile)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\DocumentFile
t -> (ByteString -> TPath
splitLocalPath (ByteString -> TPath) -> ByteString -> TPath
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BC.pack String
tName, DocumentFile
t))) [Either String DocumentFile]
c
  where -- tName is path relative to the template root directory
    isHTMLTemplate :: Bool
isHTMLTemplate = String
".tpl"  String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
fname
    correction :: p
correction = if String -> Char
forall a. [a] -> a
last String
templateRoot Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/' then p
0 else p
1
    extLen :: p
extLen     = if Bool
isHTMLTemplate then p
4 else p
5
    tName :: String
tName = Int -> String -> String
forall a. Int -> [a] -> [a]
drop ((String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
templateRoot)Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
forall p. Num p => p
correction) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$
            -- We're only dropping the template root, not the whole path
            Int -> String -> String
forall a. Int -> [a] -> [a]
take ((String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
fname) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
forall p. Num p => p
extLen) String
fname


------------------------------------------------------------------------------
-- | Loads a template at the specified path, choosing the appropriate parser
-- based on the file extension.  The template is only loaded if it has a
-- \".tpl\" or \".xtpl\" extension.  Returns an empty list if the extension
-- doesn't match.
loadTemplate' :: String -> IO [Either String DocumentFile]
loadTemplate' :: String -> IO [Either String DocumentFile]
loadTemplate' String
fullDiskPath
    | Bool
isHTMLTemplate = (Either String DocumentFile -> [Either String DocumentFile])
-> IO (Either String DocumentFile)
-> IO [Either String DocumentFile]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Either String DocumentFile
-> [Either String DocumentFile] -> [Either String DocumentFile]
forall a. a -> [a] -> [a]
:[]) (IO (Either String DocumentFile)
 -> IO [Either String DocumentFile])
-> IO (Either String DocumentFile)
-> IO [Either String DocumentFile]
forall a b. (a -> b) -> a -> b
$ String -> IO (Either String DocumentFile)
getDoc String
fullDiskPath
    | Bool
isXMLTemplate = (Either String DocumentFile -> [Either String DocumentFile])
-> IO (Either String DocumentFile)
-> IO [Either String DocumentFile]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Either String DocumentFile
-> [Either String DocumentFile] -> [Either String DocumentFile]
forall a. a -> [a] -> [a]
:[]) (IO (Either String DocumentFile)
 -> IO [Either String DocumentFile])
-> IO (Either String DocumentFile)
-> IO [Either String DocumentFile]
forall a b. (a -> b) -> a -> b
$ String -> IO (Either String DocumentFile)
getXMLDoc String
fullDiskPath
    | Bool
otherwise = [Either String DocumentFile] -> IO [Either String DocumentFile]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  where
    isHTMLTemplate :: Bool
isHTMLTemplate = String
".tpl"  String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
fullDiskPath
    isXMLTemplate :: Bool
isXMLTemplate  = String
".xtpl" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
fullDiskPath


------------------------------------------------------------------------------
-- | Type synonym for parsers.
type ParserFun = String -> ByteString -> Either String X.Document


------------------------------------------------------------------------------
-- | Reads an HTML or XML template from disk.
getDocWith :: ParserFun -> String -> IO (Either String DocumentFile)
getDocWith :: ParserFun -> String -> IO (Either String DocumentFile)
getDocWith ParserFun
parser String
f = do
    Either String ByteString
bs <- IO (Either String ByteString)
-> (SomeException -> IO (Either String ByteString))
-> IO (Either String ByteString)
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
C.catch ((ByteString -> Either String ByteString)
-> IO ByteString -> IO (Either String ByteString)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (IO ByteString -> IO (Either String ByteString))
-> IO ByteString -> IO (Either String ByteString)
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile String
f)
                (\(SomeException
e::SomeException) -> Either String ByteString -> IO (Either String ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String ByteString -> IO (Either String ByteString))
-> Either String ByteString -> IO (Either String ByteString)
forall a b. (a -> b) -> a -> b
$ String -> Either String ByteString
forall a b. a -> Either a b
Left (String -> Either String ByteString)
-> String -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)

    let eitherDoc :: Either String Document
eitherDoc = (String -> Either String Document)
-> (ByteString -> Either String Document)
-> Either String ByteString
-> Either String Document
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Either String Document
forall a b. a -> Either a b
Left (ParserFun
parser String
f) Either String ByteString
bs
    Either String DocumentFile -> IO (Either String DocumentFile)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String DocumentFile -> IO (Either String DocumentFile))
-> Either String DocumentFile -> IO (Either String DocumentFile)
forall a b. (a -> b) -> a -> b
$ (String -> Either String DocumentFile)
-> (Document -> Either String DocumentFile)
-> Either String Document
-> Either String DocumentFile
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\String
s -> String -> Either String DocumentFile
forall a b. a -> Either a b
Left (String -> Either String DocumentFile)
-> String -> Either String DocumentFile
forall a b. (a -> b) -> a -> b
$ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
                    (\Document
d -> DocumentFile -> Either String DocumentFile
forall a b. b -> Either a b
Right (DocumentFile -> Either String DocumentFile)
-> DocumentFile -> Either String DocumentFile
forall a b. (a -> b) -> a -> b
$ Document -> Maybe String -> DocumentFile
DocumentFile Document
d (String -> Maybe String
forall a. a -> Maybe a
Just String
f)) Either String Document
eitherDoc


------------------------------------------------------------------------------
-- | Reads an HTML template from disk.
getDoc :: String -> IO (Either String DocumentFile)
getDoc :: String -> IO (Either String DocumentFile)
getDoc = ParserFun -> String -> IO (Either String DocumentFile)
getDocWith ParserFun
X.parseHTML


------------------------------------------------------------------------------
-- | Reads an XML template from disk.
getXMLDoc :: String -> IO (Either String DocumentFile)
getXMLDoc :: String -> IO (Either String DocumentFile)
getXMLDoc = ParserFun -> String -> IO (Either String DocumentFile)
getDocWith ParserFun
X.parseXML


------------------------------------------------------------------------------
-- | Sets the templateMap in a HeistState.
setTemplates :: HashMap TPath DocumentFile -> HeistState n -> HeistState n
setTemplates :: HashMap TPath DocumentFile -> HeistState n -> HeistState n
setTemplates HashMap TPath DocumentFile
m HeistState n
ts = HeistState n
ts { _templateMap :: HashMap TPath DocumentFile
_templateMap = HashMap TPath DocumentFile
m }


------------------------------------------------------------------------------
-- | Adds a template to the heist state.
insertTemplate :: TPath
               -> DocumentFile
               -> HeistState n
               -> HeistState n
insertTemplate :: TPath -> DocumentFile -> HeistState n -> HeistState n
insertTemplate TPath
p DocumentFile
t HeistState n
st =
    HashMap TPath DocumentFile -> HeistState n -> HeistState n
forall (n :: * -> *).
HashMap TPath DocumentFile -> HeistState n -> HeistState n
setTemplates (TPath
-> DocumentFile
-> HashMap TPath DocumentFile
-> HashMap TPath DocumentFile
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert TPath
p DocumentFile
t (HeistState n -> HashMap TPath DocumentFile
forall (m :: * -> *). HeistState m -> HashMap TPath DocumentFile
_templateMap HeistState n
st)) HeistState n
st


------------------------------------------------------------------------------
-- Gives the MIME type for a 'X.Document'
mimeType :: X.Document -> MIMEType
mimeType :: Document -> ByteString
mimeType Document
d = case Document
d of
    (X.HtmlDocument Encoding
e Maybe DocType
_ [Node]
_) -> ByteString
"text/html;charset=" ByteString -> ByteString -> ByteString
`BC.append` Encoding -> ByteString
forall p. IsString p => Encoding -> p
enc Encoding
e
    (X.XmlDocument  Encoding
e Maybe DocType
_ [Node]
_) -> ByteString
"text/xml;charset="  ByteString -> ByteString -> ByteString
`BC.append` Encoding -> ByteString
forall p. IsString p => Encoding -> p
enc Encoding
e
  where
    enc :: Encoding -> p
enc Encoding
X.UTF8    = p
"utf-8"
    -- Should not include byte order designation for UTF-16 since
    -- rendering will include a byte order mark. (RFC 2781, Sec. 3.3)
    enc Encoding
X.UTF16BE = p
"utf-16"
    enc Encoding
X.UTF16LE = p
"utf-16"
    enc Encoding
X.ISO_8859_1 = p
"iso-8859-1"


------------------------------------------------------------------------------
-- | Binds a set of new splice declarations within a 'HeistState'.
bindAttributeSplices :: Splices (AttrSplice n) -- ^ splices to bind
                     -> HeistState n           -- ^ start state
                     -> HeistState n
bindAttributeSplices :: Splices (AttrSplice n) -> HeistState n -> HeistState n
bindAttributeSplices Splices (AttrSplice n)
ss HeistState n
hs =
    HeistState n
hs { _attrSpliceMap :: HashMap Text (AttrSplice n)
_attrSpliceMap = HeistState n
-> (HeistState n -> HashMap Text (AttrSplice n))
-> Splices (AttrSplice n)
-> HashMap Text (AttrSplice n)
forall (n :: * -> *) v a.
HeistState n
-> (HeistState n -> HashMap Text v)
-> MapSyntaxM Text v a
-> HashMap Text v
applySpliceMap HeistState n
hs HeistState n -> HashMap Text (AttrSplice n)
forall (m :: * -> *). HeistState m -> HashMap Text (AttrSplice m)
_attrSpliceMap Splices (AttrSplice n)
ss }

------------------------------------------------------------------------------
-- | Mappends a doctype to the state.
addDoctype :: Monad m => [X.DocType] -> HeistT n m ()
addDoctype :: [DocType] -> HeistT n m ()
addDoctype [DocType]
dt = do
    (HeistState n -> HeistState n) -> HeistT n m ()
forall (m :: * -> *) (n :: * -> *).
Monad m =>
(HeistState n -> HeistState n) -> HeistT n m ()
modifyHS (\HeistState n
s -> HeistState n
s { _doctypes :: [DocType]
_doctypes = HeistState n -> [DocType]
forall (m :: * -> *). HeistState m -> [DocType]
_doctypes HeistState n
s [DocType] -> [DocType] -> [DocType]
forall a. Monoid a => a -> a -> a
`mappend` [DocType]
dt })