    {-# LANGUAGE ScopedTypeVariables #-}
    {-# LANGUAGE CPP #-}
    {-# LANGUAGE RankNTypes #-}
    -- Module:      Text.Hastache.Context
    -- Copyright:   Sergey S Lymar (c) 2011-2013
    -- License:     BSD3
    -- Maintainer:  Sergey S Lymar <sergey.lymar@gmail.com>
    -- Stability:   experimental
    -- Portability: portable

    {- |
    Hastache context helpers
    -}
    module Text.Hastache.Context (
          mkStrContext
        , mkStrContextM
        , mkGenericContext
        , mkGenericContext'
        , Ext
        , defaultExt
        ) where

    import Data.Data
    import Data.Generics
    import Data.Int
    import Data.Version (Version)
    import Data.Ratio (Ratio)
    import Data.Word

    import qualified Data.ByteString as BS
    import qualified Data.ByteString.Lazy as LBS
    import qualified Data.Map as Map
    import qualified Data.Text as T
    import qualified Data.Text.Encoding as T
    import qualified Data.Text.Lazy as TL

    import Text.Hastache

    x ~> f = f $ x
    infixl 9 ~>

    -- | Make Hastache context from String -> MuType function
    mkStrContext :: Monad m => (String -> MuType m) -> MuContext m
    mkStrContext f a = decodeStr a ~> f ~> return

    -- | Make Hastache context from monadic String -> MuType function
    mkStrContextM :: Monad m => (String -> m (MuType m)) -> MuContext m
    mkStrContextM f a = decodeStr a ~> f

    type Ext = forall b. (Data b, Typeable b) => b -> String

    -- | @defaultExt ==@ 'gshow'
    defaultExt :: Ext
    defaultExt = gshow

    {- |
    Make Hastache context from Data.Data deriving type

    Supported field types:

     * ()

     * String

     * Char

     * Double

     * Float

     * Int

     * Int8

     * Int16

     * Int32

     * Int64

     * Integer

     * Word

     * Word8

     * Word16

     * Word32

     * Word64

     * Data.ByteString.ByteString

     * Data.ByteString.Lazy.ByteString

     * Data.Text.Text

     * Data.Text.Lazy.Text

     * Bool

     * Version

     * Maybe @a@ (where @a@ is a supported datatype)

     * Either @a@ @b@ (where @a@ and @b@ are supported datatypes)

     * Data.Text.Text -> Data.Text.Text

     * Data.Text.Text -> Data.Text.Lazy.Text

     * Data.Text.Lazy.Text -> Data.Text.Lazy.Text

     * Data.ByteString.ByteString -> Data.ByteString.ByteString

     * String -> String

     * Data.ByteString.ByteString -> Data.ByteString.Lazy.ByteString

     * MonadIO m => Data.Text.Text -> m Data.Text.Text

     * MonadIO m => Data.Text.Text -> m Data.Text.Lazy.Text

     * MonadIO m => Data.Text.Lazy.Text -> m Data.Text.Lazy.Text

     * MonadIO m => Data.ByteString.ByteString -> m Data.ByteString.ByteString

     * MonadIO m => String -> m String

     * MonadIO m => Data.ByteString.ByteString -> m Data.ByteString.Lazy.ByteString

    Example:

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

    data InternalData = InternalData {
        someField       :: String,
        anotherField    :: Int
        } deriving (Data, Typeable, Show)

    data Example = Example {
        stringField             :: String,
        intField                :: Int,
        dataField               :: InternalData,
        simpleListField         :: [String],
        dataListField           :: [InternalData],
        stringFunc              :: String -> String,
        textFunc                :: T.Text -> T.Text,
        monadicStringFunc       :: String -> IO String,
        monadicTextFunc         :: T.Text -> IO T.Text
        } deriving (Data, Typeable)

    example = hastacheStr defaultConfig (encodeStr template)
        (mkGenericContext context)
        where
        template = unlines [
            \"string: {{stringField}}\",
            \"int: {{intField}}\",
            \"data: {{dataField.someField}}, {{dataField.anotherField}}\",
            \"data: {{#dataField}}{{someField}}, {{anotherField}}{{/dataField}}\",
            \"simple list: {{#simpleListField}}{{.}} {{/simpleListField}}\",
            \"data list:\",
            \"{{#dataListField}}\",
            \" * {{someField}}, {{anotherField}}. top level var: {{intField}}\",
            \"{{/dataListField}}\",
            \"{{#stringFunc}}upper{{/stringFunc}}\",
            \"{{#textFunc}}reverse{{/textFunc}}\",
            \"{{#monadicStringFunc}}upper (monadic){{/monadicStringFunc}}\",
            \"{{#monadicTextFunc}}reverse (monadic){{/monadicTextFunc}}\"]
        context = Example { stringField = \"string value\", intField = 1,
            dataField = InternalData \"val\" 123, simpleListField = [\"a\",\"b\",\"c\"],
            dataListField = [InternalData \"aaa\" 1, InternalData \"bbb\" 2],
            stringFunc = map toUpper,
            textFunc = T.reverse,
            monadicStringFunc = return . map toUpper,
            monadicTextFunc = return . T.reverse }

    main = example >>= TL.putStrLn
    @

    Result:

    @
    string: string value
    int: 1
    data: val, 123
    data: val, 123
    simple list: a b c
    data list:
     * aaa, 1. top level var: 1
     * bbb, 2. top level var: 1
    UPPER
    esrever
    UPPER (MONADIC)
    )cidanom( esrever
    @

    Hastache also supports datatypes with multiple constructors:

    @
    data A = A { str :: String }
           | B { num :: Int }

    {{#A}}
    A : {{str}}
    {{/A}}
    {{#B}}
    B : {{num}}
    {{/B}}
    @

    -}
    #if MIN_VERSION_base(4,7,0)
    mkGenericContext :: (Monad m, Data a, Typeable m) => a -> MuContext m
    #else
    mkGenericContext :: (Monad m, Data a, Typeable1 m) => a -> MuContext m
    #endif
    mkGenericContext val = toGenTemp id defaultExt val ~> convertGenTempToContext

    {-|

    Like 'mkGenericContext', but apply the first function to record field
    names when constructing the context. The second function is used to
    constructing values for context from datatypes that are nor supported
    as primitives in the library. The resulting value can be accessed
    using the @.DatatypeName@ field:

    @
    \{\-\# LANGUAGE DeriveDataTypeable \#\-\}
    \{\-\# LANGUAGE FlexibleInstances \#\-\}
    \{\-\# LANGUAGE ScopedTypeVariables \#\-\}
    \{\-\# LANGUAGE StandaloneDeriving \#\-\}
    \{\-\# LANGUAGE TypeSynonymInstances \#\-\}
    import Text.Hastache
    import Text.Hastache.Context

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

    import Data.Data (Data, Typeable)
    import Data.Decimal
    import Data.Generics.Aliases (extQ)

    data Test = Test {n::Int, m::Decimal} deriving (Data, Typeable)
    deriving instance Data Decimal

    val :: Test
    val = Test 1 (Decimal 3 1500)

    q :: Ext
    q = defaultExt \`extQ\` (\(i::Decimal) -> "A decimal: " ++ show i)

    r "m" = "moo"
    r x   = x

    example :: IO TL.Text
    example = hastacheStr defaultConfig
                          (encodeStr template)
                          (mkGenericContext' r q val)

    template = concat [
         "{{n}}\\n",
         "{{moo.Decimal}}"
         ]

    main = example >>= TL.putStrLn
    @

    Result:

    @
    1
    A decimal: 1.500
    @

    -}
    #if MIN_VERSION_base(4,7,0)
    mkGenericContext' :: (Monad m, Data a, Typeable m)
                      => (String -> String) -> Ext -> a -> MuContext m
    #else
    mkGenericContext' :: (Monad m, Data a, Typeable1 m)
                      => (String -> String) -> Ext -> a -> MuContext m
    #endif
    mkGenericContext' f ext val = toGenTemp f ext val ~> convertGenTempToContext

    data TD m =
          TSimple (MuType m)
        | TObj [(String, TD m)]
        | TList [TD m]
        | TUnknown
        deriving (Show)

    #if MIN_VERSION_base(4,7,0)
    toGenTemp :: (Data a, Monad m, Typeable m)
              => (String -> String) -> Ext -> a -> TD m
    #else
    toGenTemp :: (Data a, Monad m, Typeable1 m)
              => (String -> String) -> Ext -> a -> TD m
    #endif
    toGenTemp f g a = TObj $ conName : zip fields (gmapQ (procField f g) a)
        where
        fields = toConstr a ~> constrFields ~> map f
        conName = (toConstr a ~> showConstr, TSimple . MuVariable $ g a)

    #if MIN_VERSION_base(4,7,0)
    procField :: (Data a, Monad m, Typeable m)
              => (String -> String) -> Ext -> a -> TD m
    #else
    procField :: (Data a, Monad m, Typeable1 m)
              => (String -> String) -> Ext -> a -> TD m
    #endif
    procField f g a =
        case res a of
          TUnknown -> TSimple . MuVariable . g $ a
          b        -> b
      where
        res = obj
            `ext1Q` list
            `extQ` (\(i::String)            -> MuVariable (encodeStr i) ~> TSimple)
            `extQ` (\(i::Char)              -> MuVariable i ~> TSimple)
            `extQ` (\(i::Double)            -> MuVariable i ~> TSimple)
            `extQ` (\(i::Float)             -> MuVariable i ~> TSimple)
            `extQ` (\(i::Int)               -> MuVariable i ~> TSimple)
            `extQ` (\(i::Int8)              -> MuVariable i ~> TSimple)
            `extQ` (\(i::Int16)             -> MuVariable i ~> TSimple)
            `extQ` (\(i::Int32)             -> MuVariable i ~> TSimple)
            `extQ` (\(i::Int64)             -> MuVariable i ~> TSimple)
            `extQ` (\(i::Integer)           -> MuVariable i ~> TSimple)
            `extQ` (\(i::Word)              -> MuVariable i ~> TSimple)
            `extQ` (\(i::Word8)             -> MuVariable i ~> TSimple)
            `extQ` (\(i::Word16)            -> MuVariable i ~> TSimple)
            `extQ` (\(i::Word32)            -> MuVariable i ~> TSimple)
            `extQ` (\(i::Word64)            -> MuVariable i ~> TSimple)
            `extQ` (\(i::BS.ByteString)     -> MuVariable i ~> TSimple)
            `extQ` (\(i::LBS.ByteString)    -> MuVariable i ~> TSimple)
            `extQ` (\(i::T.Text)            -> MuVariable i ~> TSimple)
            `extQ` (\(i::TL.Text)           -> MuVariable i ~> TSimple)
            `extQ` (\(i::Bool)              -> MuBool i     ~> TSimple)
            `extQ` (\()                     -> MuVariable () ~> TSimple)
            `extQ` (\(i::Version)           -> MuVariable i ~> TSimple)
            `extQ` muLambdaTT
            `extQ` muLambdaTTL
            `extQ` muLambdaTLTL
            `extQ` muLambdaBSBS
            `extQ` muLambdaSS
            `extQ` muLambdaBSLBS

            `extQ` muLambdaMTT
            `extQ` muLambdaMTTL
            `extQ` muLambdaMTLTL
            `extQ` muLambdaMBSBS
            `extQ` muLambdaMSS
            `extQ` muLambdaMBSLBS

            `ext1Q` muMaybe
            `ext2Q` muEither

        obj a = case dataTypeRep (dataTypeOf a) of
            AlgRep (_:_) -> toGenTemp f g a
            _ -> TUnknown
        list a = map (procField f g) a ~> TList

        muMaybe Nothing = TSimple MuNothing
        muMaybe (Just a) = TList [procField f g a]

        muEither (Left a) = procField f g a
        muEither (Right b) = procField f g b

        muLambdaTT :: (T.Text -> T.Text) -> TD m
        muLambdaTT f = MuLambda f ~> TSimple

        muLambdaTLTL :: (TL.Text -> TL.Text) -> TD m
        muLambdaTLTL f = MuLambda (f . TL.fromStrict) ~> TSimple

        muLambdaTTL :: (T.Text -> TL.Text) -> TD m
        muLambdaTTL f = MuLambda f ~> TSimple

        muLambdaBSBS :: (BS.ByteString -> BS.ByteString) -> TD m
        muLambdaBSBS f = MuLambda (f . T.encodeUtf8) ~> TSimple

        muLambdaBSLBS :: (BS.ByteString -> LBS.ByteString) -> TD m
        muLambdaBSLBS f = MuLambda (f . T.encodeUtf8) ~> TSimple

        muLambdaSS :: (String -> String) -> TD m
        muLambdaSS f = MuLambda fd ~> TSimple
            where
            fd s = decodeStr s ~> f

        -- monadic

        muLambdaMTT :: (T.Text -> m T.Text) -> TD m
        muLambdaMTT f = MuLambdaM f ~> TSimple

        muLambdaMTLTL :: (TL.Text -> m TL.Text) -> TD m
        muLambdaMTLTL f = MuLambdaM (f . TL.fromStrict) ~> TSimple

        muLambdaMTTL :: (T.Text -> m TL.Text) -> TD m
        muLambdaMTTL f = MuLambdaM f ~> TSimple

        muLambdaMBSBS :: (BS.ByteString -> m BS.ByteString) -> TD m
        muLambdaMBSBS f = MuLambdaM (f . T.encodeUtf8) ~> TSimple

        muLambdaMBSLBS :: (BS.ByteString -> m LBS.ByteString) -> TD m
        muLambdaMBSLBS f = MuLambdaM (f . T.encodeUtf8) ~> TSimple

        muLambdaMSS :: (String -> m String) -> TD m
        muLambdaMSS f = MuLambdaM fd ~> TSimple
            where
            fd s = decodeStr s ~> f

    convertGenTempToContext :: Monad m => TD m -> MuContext m
    convertGenTempToContext v = mkMap "" Map.empty v ~> mkMapContext
        where
        mkMap name m (TSimple t) = Map.insert (encodeStr name) t m
        mkMap name m (TObj lst) = foldl (foldTObj name) m lst ~>
            Map.insert (encodeStr name)
            ([foldl (foldTObj "") Map.empty lst ~> mkMapContext] ~> MuList)
        mkMap name m (TList lst) = Map.insert (encodeStr name)
            (map convertGenTempToContext lst ~> MuList) m
        mkMap _ m _ = m

        mkName name newName = if length name > 0
            then concat [name, ".", newName]
            else newName
        foldTObj name m (fn, fv) = mkMap (mkName name fn) m fv

        mkMapContext m a = return $ case Map.lookup a m of
            Nothing ->
                case a == dotT of
                    True ->
                        case Map.lookup T.empty m of
                            Nothing -> MuNothing
                            Just a -> a
                    _ -> MuNothing
            Just a -> a

    dotT :: T.Text
    dotT = T.singleton '.'