{-|
Module      : $Header$
Description : Functions for rendering mustache templates.
Copyright   : (c) Justus Adam, 2015
License     : BSD3
Maintainer  : dev@justus.science
Stability   : experimental
Portability : POSIX
-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Mustache.Render
  (
  -- * Substitution
    substitute, substituteValue
  -- * Working with Context
  , Context(..), search, innerSearch
  -- * Util
  , toString
  ) where


import           Control.Applicative    ((<|>))
import           Control.Arrow          (first)
import           Control.Monad

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

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

import           Data.Monoid            ((<>))
import           Text.Mustache.Internal
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 t = substituteValue t . toMustache


{-|
  Substitutes all mustache defined tokens (or tags) for values found in the
  provided data structure.
-}
substituteValue :: Template -> Value -> Text
substituteValue (Template { ast = cAst, partials = cPartials }) dataStruct =
  joinSubstituted (substitute' (Context mempty dataStruct)) cAst
  where
    joinSubstituted f = fold . fmap f

    -- Main substitution function
    substitute' :: Context Value -> Node Text -> Text

    -- subtituting text
    substitute' _ (TextBlock t) = t

    -- substituting a whole section (entails a focus shift)
    substitute' (Context parents focus@(Array a)) (Section Implicit secSTree)
      | V.null a  = mempty
      | otherwise = flip joinSubstituted a $ \focus' ->
        let
          newContext = Context (focus:parents) focus'
        in
          joinSubstituted (substitute' newContext) secSTree
    substitute' context@(Context _ (Object _)) (Section Implicit secSTree) =
      joinSubstituted (substitute' context) secSTree
    substitute' _ (Section Implicit _) = mempty
    substitute' context@(Context parents focus) (Section (NamedData secName) secSTree) =
      case search context secName of
        Just arr@(Array arrCont) ->
          if V.null arrCont
            then mempty
            else flip joinSubstituted arrCont $ \focus' ->
              let
                newContext = Context (arr:focus:parents) focus'
              in
                joinSubstituted (substitute' newContext) secSTree
        Just (Bool False) -> mempty
        Just (Lambda l)   -> joinSubstituted (substitute' context) (l context secSTree)
        Just focus'       ->
          let
            newContext = Context (focus:parents) focus'
          in
            joinSubstituted (substitute' newContext) secSTree
        Nothing -> mempty

    -- substituting an inverted section
    substitute' _       (InvertedSection  Implicit           _        ) = mempty
    substitute' context (InvertedSection (NamedData secName) invSecSTree) =
      case search context secName of
        Just (Bool False)         -> contents
        Just (Array a) | V.null a -> contents
        Nothing                   -> contents
        _                         -> mempty
      where
        contents = joinSubstituted (substitute' context) invSecSTree

    -- substituting a variable
    substitute' (Context _ current) (Variable _ Implicit) = toString current
    substitute' context (Variable escaped (NamedData varName)) =
      maybe
        mempty
        (if escaped then escapeXMLText else id)
        $ toString <$> search context varName

    -- substituting a partial
    substitute' context (Partial indent pName) =
      maybe
        mempty
        (joinSubstituted (substitute' context) . handleIndent indent . ast)
        $ HM.lookup pName cPartials


handleIndent :: Maybe Text -> STree -> STree
handleIndent Nothing ast' = ast'
handleIndent (Just indentation) ast' = preface <> content
  where
    preface = if T.null indentation then [] else [TextBlock indentation]
    content = if T.null indentation
      then ast'
      else
        let
          fullIndented = fmap (indentBy indentation) ast'
          dropper (TextBlock t) = TextBlock $
            if ("\n" <> indentation) `isSuffixOf` t
              then fromMaybe t $ stripSuffix indentation t
              else t
          dropper a = a
        in
          reverse $ fromMaybe [] (uncurry (:) . first dropper <$> uncons (reverse fullIndented))


-- | Search for a key in the current context.
--
-- The search is conducted inside out mening the current focus
-- is searched first. If the key is not found the outer scopes are recursively
-- searched until the key is found, then 'innerSearch' is called on the result.
search :: Context Value -> [Key] -> Maybe Value
search _ [] = Nothing
search ctx keys@(_:nextKeys) = go ctx keys >>= innerSearch nextKeys
  where
  go _ [] = Nothing
  go (Context parents focus) val@(x:_) =
    ( case focus of
      (Object o) -> HM.lookup x o
      _          -> Nothing
    )
    <|> ( do
          (newFocus, newParents) <- uncons parents
          go (Context newParents newFocus) val
        )

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


-- | Searches nested scopes navigating inward. Fails if it encunters something
-- other than an object before the key is expended.
innerSearch :: [Key] -> Value -> Maybe Value
innerSearch []     v          = Just v
innerSearch (y:ys) (Object o) = HM.lookup y o >>= innerSearch ys
innerSearch _      _          = Nothing


-- | Converts values to Text as required by the mustache standard
toString :: Value -> Text
toString (String t) = t
toString (Number n) = either (pack . show) (pack . show) (floatingOrInteger n :: Either Double Integer)
toString e          = pack $ show e