    {-# LANGUAGE ExistentialQuantification, FlexibleInstances, IncoherentInstances,
                 OverloadedStrings #-}
    -- Module:      Text.Hastache
    -- Copyright:   Sergey S Lymar (c) 2011-2013
    -- License:     BSD3
    -- Maintainer:  Sergey S Lymar <sergey.lymar@gmail.com>
    -- Stability:   experimental
    -- Portability: portable
    --
    -- Haskell implementation of Mustache templates

    {- | Haskell implementation of Mustache templates

    See homepage for examples of usage: <http://github.com/lymar/hastache>

    Simplest example:

    @
    import           Text.Hastache
    import           Text.Hastache.Context
    import qualified Data.Text.Lazy.IO as TL

    main = do
        res <- hastacheStr defaultConfig (encodeStr template)
            (mkStrContext context)
        TL.putStrLn res
      where
        template = \"Hello, {{name}}!\\n\\nYou have {{unread}} unread messages.\"
        context \"name\" = MuVariable \"Haskell\"
        context \"unread\" = MuVariable (100 :: Int)
    @

    Result:

    @
    Hello, Haskell!

    You have 100 unread messages.
    @

    Using Generics:

    @
    {&#45;\# LANGUAGE DeriveDataTypeable, OverloadedStrings \#&#45;}

    import           Text.Hastache
    import           Text.Hastache.Context
    import qualified Data.Text.Lazy.IO as TL
    import           Data.Data

    data Info = Info {
        name    :: String,
        unread  :: Int
        } deriving (Data, Typeable)

    main = do
        res <- hastacheStr defaultConfig template
            (mkGenericContext inf)
        TL.putStrLn res
      where
        template = \"Hello, {{name}}!\\n\\nYou have {{unread}} unread messages.\"
        inf = Info \"Haskell\" 100
    @

    -}
    module Text.Hastache (
          hastacheStr
        , hastacheFile
        , hastacheStrBuilder
        , hastacheFileBuilder
        , MuContext
        , MuType(..)
        , MuConfig(..)
        , MuVar(..)
        , composeCtx
        , htmlEscape
        , emptyEscape
        , defaultConfig
        , encodeStr
        , encodeStrLT
        , decodeStr
        , decodeStrLT
        ) where

    import Control.Monad (guard, mplus, mzero, liftM )
    import Control.Monad.Reader (ask, runReaderT, MonadReader, ReaderT)
    import Control.Monad.Trans (lift, liftIO, MonadIO)
    import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT)
    import Data.AEq (AEq,(~==))
    import Data.Functor ((<$>))
    import Data.IORef
    import Data.Int
    import Data.Maybe (isJust)
    import Data.Monoid (Monoid, mappend, mempty)
    import Data.Text hiding (map, foldl1)
    import Data.Text.IO
    import Data.Version (Version)
    import Data.Word
    import Prelude hiding (putStrLn, readFile, length, drop, tail, dropWhile, elem,
        head, last, reverse, take, span, null)
    import System.Directory (doesFileExist)
    import System.FilePath (combine)

    import qualified Data.ByteString as BS
    import qualified Data.ByteString.Lazy as LZ
    import qualified Data.List as List
    import qualified Data.Text as T
    import qualified Data.Text.Read as T
    import qualified Data.Text.Encoding as T
    import qualified Data.Text.Lazy as TL
    import qualified Data.Text.Lazy.Builder as TLB
    import qualified Data.Text.Lazy.Encoding as TL
    import qualified Data.Foldable as F
    import qualified Prelude

    (~>) :: a -> (a -> b) -> b
    x ~> f = f x
    infixl 9 ~>

    -- | Data for Hastache variable
    type MuContext m =
        Text            -- ^ Variable name
        -> m (MuType m) -- ^ Value

    instance (Monad m) => Monoid (MuContext m) where
        mempty = const $ return MuNothing
        a `mappend` b = \v -> do
            x <- a v
            case x of
                MuNothing -> b v
                _ -> return x

    -- | Left-leaning compoistion of contexts. Given contexts @c1@ and
    -- @c2@, the behaviour of @(c1 <> c2) x@ is following: if @c1 x@
    -- produces 'MuNothing', then the result is @c2 x@. Otherwise the
    -- result is @c1 x@. Even if @c1 x@ is 'MuNothing', the monadic
    -- effects of @c1@ are still to take place.
    composeCtx :: (Monad m) => MuContext m -> MuContext m -> MuContext m
    composeCtx = mappend

    class Show a => MuVar a where
        -- | Convert to lazy 'Data.Text.Lazy.Text'
        toLText   :: a -> TL.Text
        -- | Is empty variable (empty string, zero number etc.)
        isEmpty   :: a -> Bool
        isEmpty _ = False

    instance MuVar Text where
        toLText = TL.fromStrict
        isEmpty = T.null

    instance MuVar TL.Text where
        toLText = id
        isEmpty a = TL.length a == 0

    instance MuVar BS.ByteString where
        toLText = TL.fromStrict . T.decodeUtf8
        isEmpty a = BS.length a == 0

    instance MuVar LZ.ByteString where
        toLText = TL.decodeUtf8
        isEmpty a = LZ.length a == 0

    withShowToText :: Show a => a -> TL.Text
    withShowToText a = show a ~> TL.pack

    numEmpty :: (Num a,AEq a) => a -> Bool
    numEmpty a = a ~== 0

    instance MuVar Integer where {toLText = withShowToText; isEmpty = numEmpty}
    instance MuVar Int     where {toLText = withShowToText; isEmpty = numEmpty}
    instance MuVar Float   where {toLText = withShowToText; isEmpty = numEmpty}
    instance MuVar Double  where {toLText = withShowToText; isEmpty = numEmpty}
    instance MuVar Int8    where {toLText = withShowToText; isEmpty = numEmpty}
    instance MuVar Int16   where {toLText = withShowToText; isEmpty = numEmpty}
    instance MuVar Int32   where {toLText = withShowToText; isEmpty = numEmpty}
    instance MuVar Int64   where {toLText = withShowToText; isEmpty = numEmpty}
    instance MuVar Word    where {toLText = withShowToText; isEmpty = numEmpty}
    instance MuVar Word8   where {toLText = withShowToText; isEmpty = numEmpty}
    instance MuVar Word16  where {toLText = withShowToText; isEmpty = numEmpty}
    instance MuVar Word32  where {toLText = withShowToText; isEmpty = numEmpty}
    instance MuVar Word64  where {toLText = withShowToText; isEmpty = numEmpty}
    instance MuVar ()      where {toLText = withShowToText}

    instance MuVar Version where {toLText = withShowToText }

    instance MuVar Char where
        toLText = TL.singleton

    instance MuVar a => MuVar [a] where
        toLText a = toLText '[' <+> cnvLst <+> toLText ']'
            where
            cnvLst = map toLText a ~>
                    TL.intercalate (toLText ',')
            (<+>) = TL.append

    instance MuVar a => MuVar (Maybe a) where
        toLText (Just a) = toLText a
        toLText Nothing  = ""
        isEmpty Nothing  = True
        isEmpty (Just a) = isEmpty a

    instance (MuVar a, MuVar b) => MuVar (Either a b) where
        toLText (Left  a) = toLText a
        toLText (Right b) = toLText b
        isEmpty (Left  a) = isEmpty a
        isEmpty (Right b) = isEmpty b

    instance MuVar [Char] where
        toLText = TL.pack
        isEmpty a = Prelude.length a == 0

    data MuType m =
        forall a. MuVar a => MuVariable a                   |
        MuList [MuContext m]                                |
        MuBool Bool                                         |
        forall a. MuVar a => MuLambda (Text -> a)           |
        forall a. MuVar a => MuLambdaM (Text -> m a)        |
        MuNothing

    instance Show (MuType m) where
        show (MuVariable a) = "MuVariable " ++ show a
        show (MuList _) = "MuList [..]"
        show (MuBool v) = "MuBool " ++ show v
        show (MuLambda _) = "MuLambda <..>"
        show (MuLambdaM _) = "MuLambdaM <..>"
        show MuNothing = "MuNothing"

    data MuConfig m = MuConfig {
        muEscapeFunc        :: TL.Text -> TL.Text,
            -- ^ Escape function ('htmlEscape', 'emptyEscape' etc.)
        muTemplateFileDir   :: Maybe FilePath,
            -- ^ Directory for search partial templates (@{{> templateName}}@)
        muTemplateFileExt   :: Maybe String,
            -- ^ Partial template files extension
        muTemplateRead      :: FilePath -> m (Maybe Text)
            -- ^ Template retrieval function. 'Nothing' indicates that the
            --   template could not be found.
        }

    -- | Convert 'String' to 'Text'
    encodeStr :: String -> Text
    encodeStr = T.pack

    -- | Convert 'String' to Lazy 'Data.Text.Lazy.Text'
    encodeStrLT :: String -> TL.Text
    encodeStrLT = TL.pack

    -- | Convert 'Text' to 'String'
    decodeStr :: Text -> String
    decodeStr = T.unpack

    -- | Convert Lazy 'Data.Text.Lazy.Text' to 'String'
    decodeStrLT :: TL.Text -> String
    decodeStrLT = TL.unpack

    -- | isMuNothing x = x == MuNothing
    isMuNothing :: MuType t -> Bool
    isMuNothing MuNothing = True
    isMuNothing _ = False

    -- | Escape HTML symbols
    htmlEscape :: TL.Text -> TL.Text
    htmlEscape = TL.concatMap proc
      where
        proc '&'  = "&amp;"
        proc '\\' = "&#92;"
        proc '"'  = "&quot;"
        proc '\'' = "&#39;"
        proc '<'  = "&lt;"
        proc '>'  = "&gt;"
        proc h    = TL.singleton h

    -- | No escape
    emptyEscape :: TL.Text -> TL.Text
    emptyEscape = id

    {- | Default config: HTML escape function, current directory as
         template directory, template file extension not specified -}
    defaultConfig :: MonadIO m => MuConfig m
    defaultConfig = MuConfig {
        muEscapeFunc = htmlEscape,
        muTemplateFileDir = Nothing,
        muTemplateFileExt = Nothing,
        muTemplateRead = liftIO . defaultTemplateRead
        }

    defaultTemplateRead :: FilePath -> IO (Maybe Text)
    defaultTemplateRead fullFileName = do
        fe <- doesFileExist fullFileName
        if fe
            then Just <$> readFile fullFileName
            else return Nothing

    defOTag = "{{" :: Text
    defCTag = "}}" :: Text
    unquoteCTag = "}}}" :: Text

    findBlock ::
           Text
        -> Text
        -> Text
        -> Maybe (Text, Char, Text, Text)
    findBlock str otag ctag = do
        guard (length fnd > length otag)
        Just (pre, symb, inTag, afterClose)
        where
        (pre, fnd) = breakOn otag str
        symb = index fnd (length otag)
        (inTag, afterClose)
            -- test for unescape ( {{{some}}} )
            | symb == '{' && ctag == defCTag =
                breakOn unquoteCTag fnd ~> \(a,b) ->
                (drop (length otag) a, drop 3 b)
            | otherwise = breakOn ctag fnd ~> \(a,b) ->
                (drop (length otag) a, drop (length ctag) b)

    readVar :: MonadIO m => [MuContext m] -> Text -> m TL.Text
    readVar [] _ = return TL.empty
    readVar (context:parentCtx) name = do
        muType <- context name
        case muType of
            MuVariable a -> return $ toLText a
            MuBool a -> return . withShowToText $ a
            MuNothing -> do
              mb <- runMaybeT $ tryFindArrayItem context name
              case mb of
                Just (nctx,nn) -> readVar [nctx] nn
                _ -> readVar parentCtx name
            _ -> return TL.empty

    readInt :: Text -> Maybe (Int,Text)
    readInt t = eitherMaybe $ T.decimal t
      where
        eitherMaybe (Left _)  = Nothing
        eitherMaybe (Right x) = Just x

    tryFindArrayItem :: MonadIO m =>
           MuContext m
        -> Text
        -> MaybeT m (MuContext m, Text)
    tryFindArrayItem context name = do
        guard $ length idx > 1
        (idx,nxt) <- MaybeT $ return $ readInt $ tail idx
        guard $ idx >= 0
        guard $ (null nxt) || (head nxt == '.')
        muType <- lift $ context nm
        case muType of
            MuList l -> do
                guard $ idx < (List.length l)
                let ncxt = l !! idx
                if null nxt
                    then return (ncxt, dotStr) -- {{some.0}}
                    else return (ncxt, tail nxt) -- {{some.0.field}}
            _ -> mzero
        where
        (nm,idx) = breakOn dotStr name
        dotStr = "."

    findCloseSection ::
           Text
        -> Text
        -> Text
        -> Text
        -> Maybe (Text, Text)
    findCloseSection str name otag ctag = do
        guard (length after > 0)
        Just (before, drop (length close) after)
        where
        close = foldl1 append [otag, "/", name, ctag]
        (before, after) = breakOn close str

    trimCharsTest :: Char -> Bool
    trimCharsTest = (`Prelude.elem` [' ', '\t'])

    trimAll :: Text -> Text
    trimAll = dropAround trimCharsTest

    addRes :: MonadIO m => (Either T.Text TL.Text) -> ReaderT (IORef TLB.Builder) m ()
    addRes str = do
        rf <- ask
        b <- readIORef rf ~> liftIO
        let l = mappend b t
        writeIORef rf l ~> liftIO
        return ()
      where
        t = either TLB.fromText TLB.fromLazyText str

    addResT :: MonadIO m => T.Text -> ReaderT (IORef TLB.Builder) m ()
    addResT = addRes . Left

    addResTL :: MonadIO m => TL.Text -> ReaderT (IORef TLB.Builder) m ()
    addResTL = addRes . Right

    processBlock :: MonadIO m =>
           Text
        -> [MuContext m]
        -> Text
        -> Text
        -> MuConfig m
        -> ReaderT (IORef TLB.Builder) m ()
    processBlock str contexts otag ctag conf =
        case findBlock str otag ctag of
            Just (pre, symb, inTag, afterClose) -> do
                addResT pre
                renderBlock contexts symb inTag afterClose otag ctag conf
            Nothing -> do
                addResT str
                return ()

    elem :: Char -> Text -> Bool
    elem c = isJust . find (==c)

    renderBlock :: MonadIO m =>
           [MuContext m]
        -> Char
        -> Text
        -> Text
        -> Text
        -> Text
        -> MuConfig m
        -> ReaderT (IORef TLB.Builder) m ()
    renderBlock contexts symb inTag afterClose otag ctag conf
        -- comment
        | symb == '!' = next afterClose
        -- unescape variable
        | symb == '&' || (symb == '{' && otag == defOTag) = do
            addResTL =<< lift (readVar contexts (tail inTag ~> trimAll))
            next afterClose
        -- section, inverted section
        | symb == '#' || symb == '^' =
            case findCloseSection afterClose (tail inTag) otag ctag of
                Nothing -> next afterClose
                Just (sectionContent', afterSection') ->
                    let
                        dropNL str =
                            if length str > 0 && head str == '\n'
                               then tail str
                               else str
                        sectionContent = dropNL sectionContent'
                        afterSection =
                            if '\n' `elem` sectionContent
                                then dropNL afterSection'
                                else afterSection'
                        tlInTag = tail inTag
                        readContext' = MaybeT $ liftM (List.find (not . isMuNothing)) $
                                         mapM ($ tlInTag) contexts
                        readContextWithIdx = do
                          (ctx,name) <- Prelude.foldr mplus mzero $
                                        map (\c -> tryFindArrayItem c tlInTag) contexts
                          lift $ ctx name
                        readContext = readContext' `mplus` readContextWithIdx
                        processAndNext = do
                            processBlock sectionContent contexts otag ctag conf
                            next afterSection
                    in do
                    mbCtx <- lift $ runMaybeT readContext
                    if symb == '#'
                        then
                          case mbCtx of -- section
                            Just (MuList []) -> next afterSection
                            Just (MuList b) -> do
                                mapM_ (\c -> processBlock sectionContent
                                    (c:contexts) otag ctag conf) b
                                next afterSection
                            Just (MuVariable a) -> if isEmpty a
                                then next afterSection
                                else processAndNext
                            Just (MuBool True) -> processAndNext
                            Just (MuLambda func) -> do
                                func sectionContent ~> toLText ~> addResTL
                                next afterSection
                            Just (MuLambdaM func) -> do
                                res <- lift (func sectionContent)
                                res ~> toLText ~> addResTL
                                next afterSection
                            _ -> next afterSection
                        else case mbCtx of -- inverted section
                            Just (MuList []) -> processAndNext
                            Just (MuBool False) -> processAndNext
                            Just (MuVariable a) -> if isEmpty a
                                then processAndNext
                                else next afterSection
                            Nothing -> processAndNext
                            _ -> next afterSection
        -- set delimiter
        | symb == '=' =
            let
                lenInTag = length inTag
                delimitersCommand = take (lenInTag - 1) inTag ~> drop 1
                getDelimiter = do
                    guard $ lenInTag > 4
                    guard $ index inTag (lenInTag - 1) == '='
                    [newOTag,newCTag] <- Just $ splitOn (singleton ' ') delimitersCommand
                    Just (newOTag, newCTag)
            in case getDelimiter of
                    Nothing -> next afterClose
                    Just (newOTag, newCTag) ->
                        processBlock (trim' afterClose) contexts
                            newOTag newCTag conf
        -- partials
        | symb == '>' =
            let
                fileName' = tail inTag ~> trimAll
                fileName'' = case muTemplateFileExt conf of
                    Nothing -> fileName'
                    Just ext -> fileName' `append` encodeStr ext
                fileName = decodeStr fileName''
                fullFileName = case muTemplateFileDir conf of
                    Nothing -> fileName
                    Just path -> combine path fileName
            in do
                F.mapM_ next =<< lift (muTemplateRead conf fullFileName)
                next (trim' afterClose)
        -- variable
        | otherwise = do
            addResTL . muEscapeFunc conf =<<
              lift (readVar contexts $ trimAll inTag)
            next afterClose
        where
        next t = processBlock t contexts otag ctag conf
        trim' content =
            dropWhile trimCharsTest content
            ~> \t -> if length t > 0 && head t == '\n'
                then tail t else content

    -- | Render Hastache template from 'Text'
    hastacheStr :: (MonadIO m) =>
           MuConfig m       -- ^ Configuration
        -> Text             -- ^ Template
        -> MuContext m      -- ^ Context
        -> m TL.Text
    hastacheStr conf str context =
        hastacheStrBuilder conf str context >>= return . TLB.toLazyText

    -- | Render Hastache template from file
    hastacheFile :: (MonadIO m) =>
           MuConfig m       -- ^ Configuration
        -> FilePath         -- ^ Template file name
        -> MuContext m      -- ^ Context
        -> m TL.Text
    hastacheFile conf file_name context =
        hastacheFileBuilder conf file_name context >>= return . TLB.toLazyText

    -- | Render Hastache template from 'Text'
    hastacheStrBuilder :: (MonadIO m) =>
           MuConfig m       -- ^ Configuration
        -> Text             -- ^ Template
        -> MuContext m      -- ^ Context
        -> m TLB.Builder
    hastacheStrBuilder conf str context = do
        rf <- newIORef mempty ~> liftIO
        runReaderT (processBlock str [context] defOTag defCTag conf) rf
        readIORef rf ~> liftIO

    -- | Render Hastache template from file
    hastacheFileBuilder :: (MonadIO m) =>
           MuConfig m       -- ^ Configuration
        -> FilePath         -- ^ Template file name
        -> MuContext m      -- ^ Context
        -> m TLB.Builder
    hastacheFileBuilder conf file_name context = do
        str <- readFile file_name ~> liftIO
        hastacheStrBuilder conf str context