{-# LANGUAGE OverloadedStrings #-}
module Text.Templating.Heist.Aeson
    ( JsonT
    , JsonTemplate
    , JsonState
    , JsonSpliceT
    , JsonSplice
    , addHeistAeson
    , runJsonT
    , renderJsonTemplate
    ) where

import Data.Aeson                            ( Value(..), Array )
import Text.Templating.Heist
import Blaze.ByteString.Builder              ( Builder )
import qualified Data.Map as Map             ( lookup )
import qualified Data.Vector as V            ( forM, toList )

import qualified Data.ByteString as Strict   ( ByteString )

import qualified Text.XmlHtml as X
import qualified Data.Text as T              ( Text, append, pack, splitOn )

import Control.Monad.Reader                  ( ReaderT, ask, local, runReaderT )


data JsonInput = JsonInput { jsonRoot    :: Value
                           , jsonCurrent :: Value
                           , jsonHistory :: [Value] }

mkJsonInput value
    = JsonInput { jsonRoot = value
                , jsonCurrent = value
                , jsonHistory = [] }

type JsonT m = ReaderT JsonInput m
type JsonTemplate m a = TemplateMonad (JsonT m) a
type JsonState m = TemplateState (JsonT m)
type JsonSpliceT m = Splice (JsonT m)
type JsonSplice = JsonSpliceT IO

withValue :: Monad m => Value -> JsonSpliceT m -> JsonSpliceT m
withValue value
    = local $ \input -> input{jsonCurrent = value, jsonHistory = jsonCurrent input : jsonHistory input}

jsonSplice :: Monad m => JsonSpliceT m
jsonSplice
    = do node <-getParamNode
         let attrs = X.elementAttrs node
             methods = [ ("value", jsonValue)
                       , ("section", jsonSection)
                       , ("no-section", jsonNoSection)
                       , ("for-each", jsonForEach) ]
         case [ action val | (key, val) <- attrs, (mKey, action) <- methods, key == mKey ] of
           [x] -> x
           []  -> error "No method invoked."
           _   -> error "More than one method invoked."

jsonValue :: Monad m => T.Text -> JsonSpliceT m
jsonValue identifier
    = withTextValue identifier $ \txt ->
      return [X.TextNode txt]

jsonSection :: Monad m => T.Text -> JsonSpliceT m
jsonSection identifier
    = withAnyValue identifier $ \json ->
      withValue json $
      runChildren

jsonNoSection :: Monad m => T.Text -> JsonSpliceT m
jsonNoSection identifier
    = do input <- ask
         case findWithIdentifier identifier input of
           Just{}  -> return []
           Nothing -> runChildren

jsonForEach :: Monad m => T.Text -> JsonSpliceT m
jsonForEach identifier
    = withArrayValue identifier $ \array ->
      do result <- V.forM array $ \entry -> withValue entry runChildren
         return $ concat (V.toList result)



withArrayValue ::Monad m => T.Text -> (Array -> JsonSpliceT m) -> JsonSpliceT m
withArrayValue nodeIdentifier action
    = withAnyValue nodeIdentifier $ \json ->
      case json of
        Array array -> action array
        _           -> return [X.TextNode $ "Json value expected to be an array: " `T.append` nodeIdentifier]

withTextValue ::Monad m => T.Text -> (T.Text -> JsonSpliceT m) -> JsonSpliceT m
withTextValue nodeIdentifier action
    = withAnyValue nodeIdentifier $ \json ->
      case json of
        Object object -> action "object"
        Array{}       -> action "array"
        String string -> action string
        Number num    -> action (T.pack $ show num)
        Bool bool     -> action (T.pack $ show bool)
        Null          -> action "null"

withAnyValue :: Monad m => T.Text -> (Value -> JsonSpliceT m) -> JsonSpliceT m
withAnyValue nodeIdentifier action
    = do input <- ask
         case findWithIdentifier nodeIdentifier input of
           Nothing    -> return []
           Just value -> action value
{-
  Return corresponding json values for identifiers such as:
    "."
    "key"
    "object/key"
    "../object/./key"
-}
findWithIdentifier :: T.Text -> JsonInput -> Maybe Value
findWithIdentifier identifier input
    = case T.splitOn "/" identifier of
        "":rest -> worker (jsonRoot input) [] rest
        rest    -> worker (jsonCurrent input) (jsonHistory input) rest
    where worker current history []
              = Just current
          worker current history (".":xs)
              = worker current history xs
          worker current [] ("..":xs)
              = error "Asked to access parent node of the top-level."
          worker current (now:later) ("..":xs)
              = worker now later xs
          worker current history (key:xs)
              = case current of
                  Object object | Just value <- Map.lookup key object
                    -> worker value (current:history) xs
                  _ -> Nothing

bindStrict :: Monad m => Splice m
bindStrict = do
    node <- getParamNode
    cs <- runChildren
    maybe (return ()) (add cs)
          (X.getAttribute "tag" node)
    return []

  where
    add cs nm = modifyTS $ bindSplice nm $ do
        return cs

addHeistAeson :: Monad m => JsonState m -> JsonState m
addHeistAeson = bindSplices [ ("json", jsonSplice)
                            , ("bind", bindStrict) ]

renderJsonTemplate :: Monad m => JsonState m -> Strict.ByteString -> Value -> m (Maybe (Builder, MIMEType))
renderJsonTemplate state tplName json
    = runReaderT (renderTemplate state tplName) (mkJsonInput json)

runJsonT :: Monad m => JsonT m a -> Value -> m a
runJsonT action json
    = runReaderT action (mkJsonInput json)