{-|
Module      : $Header$
Description : Functions for rendering mustache templates.
Copyright   : (c) Justus Adam, 2015
License     : BSD3
Maintainer  : dev@justus.science
Stability   : experimental
Portability : POSIX
-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TypeSynonymInstances       #-}
{-# OPTIONS_GHC -fno-warn-orphans  #-}
module Text.Mustache.Render
  (
  -- * Substitution
    substitute, substituteValue
  -- * Checked substitution
  , checkedSubstitute, checkedSubstituteValue, SubstitutionError(..)
  -- * Working with Context
  , Context(..), search, innerSearch, SubM, substituteNode, substituteAST, catchSubstitute
  -- * Util
  , toString
  ) where


import           Control.Arrow                (first, second)
import           Control.Monad

import           Data.Foldable                (for_)
import           Data.HashMap.Strict          as HM hiding (keys, map)
import           Data.Maybe                   (fromMaybe)

import           Data.Scientific              (floatingOrInteger)
import           Data.Text                    as T (Text, isSuffixOf, pack,
                                                    replace, stripSuffix)
import qualified Data.Vector                  as V
import           Prelude                      hiding (length, lines, unlines)

import           Control.Monad.Reader
import           Control.Monad.Writer
import qualified Data.Text                    as T
import qualified Data.Text.Lazy               as LT
import           Text.Mustache.Internal
import           Text.Mustache.Internal.Types
import           Text.Mustache.Types


{-|
  Substitutes all mustache defined tokens (or tags) for values found in the
  provided data structure.

  Equivalent to @substituteValue . toMustache@.
-}
substitute :: ToMustache k => Template -> k -> Text
substitute :: forall k. ToMustache k => Template -> k -> Text
substitute Template
t = Template -> Value -> Text
substituteValue Template
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ω. ToMustache ω => ω -> Value
toMustache


{-|
  Substitutes all mustache defined tokens (or tags) for values found in the
  provided data structure and report any errors and warnings encountered during
  substitution.

  This function always produces results, as in a fully substituted/rendered template,
  it never halts on errors. It simply reports them in the first part of the tuple.
  Sites with errors are usually substituted with empty string.

  The second value in the tuple is a template rendered with errors ignored.
  Therefore if you must enforce that there were no errors during substitution
  you must check that the error list in the first tuple value is empty.

  Equivalent to @checkedSubstituteValue . toMustache@.
-}
checkedSubstitute :: ToMustache k => Template -> k -> ([SubstitutionError], Text)
checkedSubstitute :: forall k.
ToMustache k =>
Template -> k -> ([SubstitutionError], Text)
checkedSubstitute Template
t = Template -> Value -> ([SubstitutionError], Text)
checkedSubstituteValue Template
t forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ω. ToMustache ω => ω -> Value
toMustache


{-|
  Substitutes all mustache defined tokens (or tags) for values found in the
  provided data structure.
-}
substituteValue :: Template -> Value -> Text
substituteValue :: Template -> Value -> Text
substituteValue = (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Template -> Value -> ([SubstitutionError], Text)
checkedSubstituteValue


{-|
  Substitutes all mustache defined tokens (or tags) for values found in the
  provided data structure and report any errors and warnings encountered during
  substitution.

  This function always produces results, as in a fully substituted/rendered template,
  it never halts on errors. It simply reports them in the first part of the tuple.
  Sites with errors are usually substituted with empty string.

  The second value in the tuple is a template rendered with errors ignored.
  Therefore if you must enforce that there were no errors during substitution
  you must check that the error list in the first tuple value is empty.
-}
checkedSubstituteValue :: Template -> Value -> ([SubstitutionError], Text)
checkedSubstituteValue :: Template -> Value -> ([SubstitutionError], Text)
checkedSubstituteValue Template
template Value
dataStruct =
  forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ forall a.
SubM a
-> Context Value -> TemplateCache -> ([SubstitutionError], [Text])
runSubM (STree -> SubM ()
substituteAST (Template -> STree
ast Template
template)) (forall α. [α] -> α -> Context α
Context forall a. Monoid a => a
mempty Value
dataStruct) (Template -> TemplateCache
partials Template
template)

-- | Catch the results of running the inner substitution.
catchSubstitute :: SubM a -> SubM (a, Text)
catchSubstitute :: forall a. SubM a -> SubM (a, Text)
catchSubstitute = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ([Text] -> Text
T.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
RWS
  (Context Value, TemplateCache) ([SubstitutionError], [Text]) () a
-> SubM a
SubM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}.
RWST
  (Context Value, TemplateCache)
  ([SubstitutionError], [Text])
  ()
  Identity
  a
-> RWST
     (Context Value, TemplateCache)
     ([SubstitutionError], [Text])
     ()
     Identity
     a
hideResults forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
SubM a
-> RWS
     (Context Value, TemplateCache) ([SubstitutionError], [Text]) () a
runSubM'
  where
    hideResults :: RWST
  (Context Value, TemplateCache)
  ([SubstitutionError], [Text])
  ()
  Identity
  a
-> RWST
     (Context Value, TemplateCache)
     ([SubstitutionError], [Text])
     ()
     Identity
     a
hideResults = forall w (m :: * -> *) a. MonadWriter w m => (w -> w) -> m a -> m a
censor (\([SubstitutionError]
errs, [Text]
_) -> ([SubstitutionError]
errs, []))

-- | Substitute an entire 'STree' rather than just a single 'Node'
substituteAST :: STree -> SubM ()
substituteAST :: STree -> SubM ()
substituteAST = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Node Text -> SubM ()
substituteNode


-- | Main substitution function
substituteNode :: Node Text -> SubM ()

-- subtituting text
substituteNode :: Node Text -> SubM ()
substituteNode (TextBlock Text
t) = Text -> SubM ()
tellSuccess Text
t

-- substituting a whole section (entails a focus shift)
substituteNode (Section DataIdentifier
Implicit STree
secSTree) =
  forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a, b) -> a
fst forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Context [Value]
parents focus :: Value
focus@(Array Array
a)
      | forall a. Vector a -> Bool
V.null Array
a  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise -> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Array
a forall a b. (a -> b) -> a -> b
$ \Value
focus' ->
        let newContext :: Context Value
newContext = forall α. [α] -> α -> Context α
Context (Value
focusforall a. a -> [a] -> [a]
:[Value]
parents) Value
focus'
        in forall a. Context Value -> SubM a -> SubM a
shiftContext Context Value
newContext forall a b. (a -> b) -> a -> b
$ STree -> SubM ()
substituteAST STree
secSTree
    Context [Value]
_ (Object Object
_) -> STree -> SubM ()
substituteAST STree
secSTree
    Context [Value]
_ Value
v -> SubstitutionError -> SubM ()
tellError forall a b. (a -> b) -> a -> b
$ String -> SubstitutionError
InvalidImplicitSectionContextType forall a b. (a -> b) -> a -> b
$ Value -> String
showValueType Value
v

substituteNode (Section (NamedData [Text]
secName) STree
secSTree) =
  [Text] -> SubM (Maybe Value)
search [Text]
secName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just arr :: Value
arr@(Array Array
arrCont) ->
      if forall a. Vector a -> Bool
V.null Array
arrCont
        then forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
          Context [Value]
parents Value
focus <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a, b) -> a
fst
          forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Array
arrCont forall a b. (a -> b) -> a -> b
$ \Value
focus' ->
            let newContext :: Context Value
newContext = forall α. [α] -> α -> Context α
Context (Value
arrforall a. a -> [a] -> [a]
:Value
focusforall a. a -> [a] -> [a]
:[Value]
parents) Value
focus'
            in forall a. Context Value -> SubM a -> SubM a
shiftContext Context Value
newContext forall a b. (a -> b) -> a -> b
$ STree -> SubM ()
substituteAST STree
secSTree
    Just (Bool Bool
False) -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Value
Null         -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just (Lambda STree -> SubM STree
l)   -> STree -> SubM ()
substituteAST forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STree -> SubM STree
l STree
secSTree
    Just Value
focus'       -> do
      Context [Value]
parents Value
focus <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a, b) -> a
fst
      let newContext :: Context Value
newContext = forall α. [α] -> α -> Context α
Context (Value
focusforall a. a -> [a] -> [a]
:[Value]
parents) Value
focus'
      forall a. Context Value -> SubM a -> SubM a
shiftContext Context Value
newContext forall a b. (a -> b) -> a -> b
$ STree -> SubM ()
substituteAST STree
secSTree
    Maybe Value
Nothing -> SubstitutionError -> SubM ()
tellError forall a b. (a -> b) -> a -> b
$ [Text] -> SubstitutionError
SectionTargetNotFound [Text]
secName

-- substituting an inverted section
substituteNode (InvertedSection  DataIdentifier
Implicit STree
_) = SubstitutionError -> SubM ()
tellError SubstitutionError
InvertedImplicitSection
substituteNode (InvertedSection (NamedData [Text]
secName) STree
invSecSTree) =
  [Text] -> SubM (Maybe Value)
search [Text]
secName forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (Bool Bool
False) -> SubM ()
contents
    Just (Array Array
a)    | forall a. Vector a -> Bool
V.null Array
a -> SubM ()
contents
    Just Value
Null         -> SubM ()
contents
    Maybe Value
Nothing           -> SubM ()
contents
    Maybe Value
_                 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    contents :: SubM ()
contents = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Node Text -> SubM ()
substituteNode STree
invSecSTree

-- substituting a variable
substituteNode (Variable Bool
_ DataIdentifier
Implicit) = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall α. Context α -> α
ctxtFocus forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> SubM Text
toString forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> SubM ()
tellSuccess
substituteNode (Variable Bool
escaped (NamedData [Text]
varName)) =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe
    (SubstitutionError -> SubM ()
tellError forall a b. (a -> b) -> a -> b
$ [Text] -> SubstitutionError
VariableNotFound [Text]
varName)
    (Value -> SubM Text
toString forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> SubM ()
tellSuccess forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool
escaped then Text -> Text
escapeXMLText else forall a. a -> a
id))
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Text] -> SubM (Maybe Value)
search [Text]
varName

-- substituting a partial
substituteNode (Partial Maybe Text
indent String
pName) = do
  TemplateCache
cPartials <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a, b) -> b
snd
  case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup String
pName TemplateCache
cPartials of
    Maybe Template
Nothing -> SubstitutionError -> SubM ()
tellError forall a b. (a -> b) -> a -> b
$ String -> SubstitutionError
PartialNotFound String
pName
    Just Template
t ->
      let ast' :: STree
ast' = Maybe Text -> STree -> STree
handleIndent Maybe Text
indent forall a b. (a -> b) -> a -> b
$ Template -> STree
ast Template
t
      in forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Template -> TemplateCache
partials Template
t forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`HM.union`)) forall a b. (a -> b) -> a -> b
$ STree -> SubM ()
substituteAST STree
ast'


showValueType :: Value -> String
showValueType :: Value -> String
showValueType Value
Null       = String
"Null"
showValueType (Object Object
_) = String
"Object"
showValueType (Array Array
_)  = String
"Array"
showValueType (String Text
_) = String
"String"
showValueType (Lambda STree -> SubM STree
_) = String
"Lambda"
showValueType (Number Scientific
_) = String
"Number"
showValueType (Bool Bool
_)   = String
"Bool"


handleIndent :: Maybe Text -> STree -> STree
handleIndent :: Maybe Text -> STree -> STree
handleIndent Maybe Text
Nothing STree
ast' = STree
ast'
handleIndent (Just Text
indentation) STree
ast' = STree
preface forall a. Semigroup a => a -> a -> a
<> STree
content
  where
    preface :: STree
preface = if Text -> Bool
T.null Text
indentation then [] else [forall α. α -> Node α
TextBlock Text
indentation]
    content :: STree
content = if Text -> Bool
T.null Text
indentation
      then STree
ast'
      else forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [] (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Node Text -> Node Text
dropper forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall α. [α] -> Maybe (α, [α])
uncons (forall a. [a] -> [a]
reverse STree
fullIndented))
      where
        fullIndented :: STree
fullIndented = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Node Text -> Node Text
indentBy Text
indentation) STree
ast'
        dropper :: Node Text -> Node Text
dropper (TextBlock Text
t) = forall α. α -> Node α
TextBlock forall a b. (a -> b) -> a -> b
$
          if (Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
indentation) Text -> Text -> Bool
`isSuffixOf` Text
t
            then forall a. a -> Maybe a -> a
fromMaybe Text
t forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
stripSuffix Text
indentation Text
t
            else Text
t
        dropper Node Text
a = Node Text
a

indentBy :: Text -> Node Text -> Node Text
indentBy :: Text -> Node Text -> Node Text
indentBy Text
indent p :: Node Text
p@(Partial (Just Text
indent') String
name')
  | Text -> Bool
T.null Text
indent = Node Text
p
  | Bool
otherwise = forall α. Maybe α -> String -> Node α
Partial (forall a. a -> Maybe a
Just (Text
indent forall a. Semigroup a => a -> a -> a
<> Text
indent')) String
name'
indentBy Text
indent (Partial Maybe Text
Nothing String
name') = forall α. Maybe α -> String -> Node α
Partial (forall a. a -> Maybe a
Just Text
indent) String
name'
indentBy Text
indent (TextBlock Text
t) = forall α. α -> Node α
TextBlock forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> Text
replace Text
"\n" (Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
indent) Text
t
indentBy Text
_ Node Text
a = Node Text
a



-- | Converts values to Text as required by the mustache standard
toString :: Value -> SubM Text
toString :: Value -> SubM Text
toString (String Text
t) = forall (m :: * -> *) a. Monad m => a -> m a
return Text
t
toString (Number Scientific
n) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (String -> Text
pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (forall r i. (RealFloat r, Integral i) => Scientific -> Either r i
floatingOrInteger Scientific
n :: Either Double Integer)
toString (Lambda STree -> SubM STree
l) = do
  ((), Text
res) <- forall a. SubM a -> SubM (a, Text)
catchSubstitute forall a b. (a -> b) -> a -> b
$ STree -> SubM ()
substituteAST forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< STree -> SubM STree
l []
  forall (m :: * -> *) a. Monad m => a -> m a
return Text
res
toString Value
e          = do
  SubstitutionError -> SubM ()
tellError forall a b. (a -> b) -> a -> b
$ Value -> SubstitutionError
DirectlyRenderedValue Value
e
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Value
e


instance ToMustache (Context Value -> STree -> STree) where
  toMustache :: (Context Value -> STree -> STree) -> Value
toMustache Context Value -> STree -> STree
f = (STree -> SubM STree) -> Value
Lambda forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SubM (Context Value)
askContext) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip Context Value -> STree -> STree
f

instance ToMustache (Context Value -> STree -> Text) where
  toMustache :: (Context Value -> STree -> Text) -> Value
toMustache = forall r. (r -> Text) -> (Context Value -> STree -> r) -> Value
lambdaHelper forall a. a -> a
id

instance ToMustache (Context Value -> STree -> LT.Text) where
  toMustache :: (Context Value -> STree -> Text) -> Value
toMustache = forall r. (r -> Text) -> (Context Value -> STree -> r) -> Value
lambdaHelper Text -> Text
LT.toStrict

instance ToMustache (Context Value -> STree -> String) where
  toMustache :: (Context Value -> STree -> String) -> Value
toMustache = forall r. (r -> Text) -> (Context Value -> STree -> r) -> Value
lambdaHelper String -> Text
pack

lambdaHelper :: (r -> Text) -> (Context Value -> STree -> r) -> Value
lambdaHelper :: forall r. (r -> Text) -> (Context Value -> STree -> r) -> Value
lambdaHelper r -> Text
conv Context Value -> STree -> r
f = (STree -> SubM STree) -> Value
Lambda forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SubM (Context Value)
askContext) forall b c a. (b -> c) -> (a -> b) -> a -> c
. STree -> Context Value -> STree
wrapper
  where
    wrapper ::  STree -> Context Value -> STree
    wrapper :: STree -> Context Value -> STree
wrapper STree
lSTree Context Value
c = [forall α. α -> Node α
TextBlock forall a b. (a -> b) -> a -> b
$ r -> Text
conv forall a b. (a -> b) -> a -> b
$ Context Value -> STree -> r
f Context Value
c STree
lSTree]

instance ToMustache (STree -> SubM Text) where
  toMustache :: (STree -> SubM Text) -> Value
toMustache STree -> SubM Text
f = (STree -> SubM STree) -> Value
Lambda (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall α. α -> Node α
TextBlock) forall b c a. (b -> c) -> (a -> b) -> a -> c
. STree -> SubM Text
f)