    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE TemplateHaskell #-}
    {-# LANGUAGE TupleSections #-}
    {-# LANGUAGE CPP #-}
    {-# OPTIONS_GHC -fno-warn-orphans #-}

    {- |
    Module      :  Text.Heterocephalus

    Copyright   :  Kadzuya Okamoto 2016
    License     :  MIT

    Stability   :  experimental
    Portability :  unknown

    This module exports functions for working with frontend templates from Haskell.
    -}

    module Text.Heterocephalus
      (
      -- * Core functions
        compileTextFile
      , compileTextFileWith
      , compileTextFileWithDefault
      , compileHtmlFile
      , compileHtmlFileWith
      , compileHtmlFileWithDefault

      -- * QuasiQuoters
      , compileText
      , compileHtml

      -- * ScopeM
      , ScopeM
      , setDefault
      , overwrite

      -- * low-level
      , HeterocephalusSetting(..)
      , textSetting
      , htmlSetting
      , ParseOptions(..)
      , defaultParseOptions
      , createParseOptions
      , DefaultScope
      , compile
      , compileWith
      , compileWithDefault
      , compileFile
      , compileFileWith
      , compileFileWithDefault
      , compileFromString
      , compileFromStringWithDefault
      ) where

    #if MIN_VERSION_base(4,9,0)
    #else
    import Control.Applicative ((<$>), (<*>), Applicative(..))
    import Data.Monoid (Monoid, mempty, mappend)
    #endif
    import Control.Monad (forM)
    import Data.Char (isDigit)
    import Data.DList (DList)
    import qualified Data.DList as DList
    import qualified Data.Foldable as F
    import Data.List (intercalate)
    import qualified Data.Semigroup as Sem
    import Data.String (IsString(..))
    import Data.Text (Text, pack)
    import qualified Data.Text.Lazy as TL
    import Language.Haskell.TH.Lib (ExpQ, varE)
    import Language.Haskell.TH.Quote
           (QuasiQuoter(QuasiQuoter), quoteExp, quoteDec, quotePat, quoteType)
    #if MIN_VERSION_template_haskell(2,9,0)
    import Language.Haskell.TH.Syntax
           (Body(..), Con(..), Dec(..), Exp(..), Info(..), Lit(..), Match(..),
            Name(..), Pat(..), Q, Stmt(..), lookupValueName, mkName, nameBase,
            newName, qAddDependentFile, qRunIO, reify)
    #else
    import Language.Haskell.TH.Syntax
    #endif
    import Text.Blaze (preEscapedToMarkup)
    import Text.Blaze.Html (toHtml)
    import Text.Blaze.Internal (preEscapedText)
    import Text.Hamlet (Html, HtmlUrl, HtmlUrlI18n, condH)
    import Text.Hamlet.Parse
           (Binding(..), DataConstr(..), Module(Module), specialOrIdent)
    import Text.Shakespeare.Base
           (Deref, Ident(..), Scope, derefToExp, readUtf8File)

    import Text.Heterocephalus.Parse
           (Doc(..), Content(..), ParseOptions(..), createParseOptions,
            defaultParseOptions, docFromString)

    {- $setup
      >>> :set -XTemplateHaskell -XQuasiQuotes
      >>> import Text.Blaze.Renderer.String
    -}

    {-| A function to compile template file.
      This function __DOES NOT__ escape template variables.
      To render the compiled file, use @'Text.Blaze.Renderer'.*.renderMarkup@.

      >>> putStr $ renderMarkup (let as = ["<a>", "b"] in $(compileTextFile "templates/sample.txt"))
      sample
      key: <a>,
      key: b,
     -}
    compileTextFile :: FilePath -> Q Exp
    compileTextFile = compileFile textSetting

    {-| Same as 'compileText' but allows the user to specify extra values for template parameters.
      Values declared by 'overwrite' overwrites same name variables.
      Values declared by 'setDefault' are overwritten by same name variables.

    >>> :set -XOverloadedStrings
    >>> :{
    putStr $ renderMarkup (
      let as = ["<a>", "b"]
      in $(compileTextFileWith "templates/sample.txt" $ do
        setDefault "as" [| ["foo", "bar"] |]
      )
    )
    :}
    sample
    key: <a>,
    key: b,

    >>> :{
    putStr $ renderMarkup (
      let as = ["<a>", "b"]
      in $(compileTextFileWith "templates/sample.txt" $ do
        overwrite "as" [| ["foo", "bar"] |]
      )
    )
    :}
    sample
    key: foo,
    key: bar,

    >>> :{
    putStr $ renderMarkup (
      let as = ["<a>", "b"]
      in $(compileTextFileWith "templates/sample.txt" $ do
        overwrite "as" [| ["bazbaz", "barbar"] |]
        setDefault "as" [| ["foo", "bar"] |]
        overwrite "as" [| ["baz", "foobar"] |]
      )
    )
    :}
    sample
    key: baz,
    key: foobar,
     -}
    compileTextFileWith :: FilePath -> ScopeM () -> Q Exp
    compileTextFileWith fp scopeM = compileFileWith scopeM textSetting fp

    {-| Same as 'compileText' but allows the user to specify default values for template parameters.

    >>> :set -XOverloadedStrings
    >>> :{
    putStr $ renderMarkup (
      let as = ["<a>", "b"]
      in $(compileTextFileWithDefault "templates/sample.txt"
        [("as", [| ["foo", "bar"] |])]
      )
    )
    :}
    sample
    key: <a>,
    key: b,

    >>> :{
    putStr $ renderMarkup (
      $(compileTextFileWithDefault "templates/sample.txt"
        [("as", [| ["foo", "bar"] |])]
      )
    )
    :}
    sample
    key: foo,
    key: bar,
     -}
    compileTextFileWithDefault :: FilePath -> DefaultScope -> Q Exp
    compileTextFileWithDefault fp scope = compileFileWithDefault scope textSetting fp

    {-| Same as 'compileTextFile' but escapes template variables in HTML.

      >>> putStr $ renderMarkup (let as = ["<a>", "b"] in $(compileHtmlFile "templates/sample.txt"))
      sample
      key: &lt;a&gt;,
      key: b,
     -}
    compileHtmlFile :: FilePath -> Q Exp
    compileHtmlFile fp = compileHtmlFileWithDefault fp []

    {-| Same as 'compileHtmlFile' but allows the user to specify extra values for template parameters.
      Values declared by 'overwrite' overwrites same name variables.
      Values declared by 'setDefault' are overwritten by same name variables.

    >>> :set -XOverloadedStrings
    >>> :{
    putStr $ renderMarkup (
      let as = ["<a>", "b"]
      in $(compileHtmlFileWith "templates/sample.txt" $ do
        setDefault "as" [| ["foo", "bar"] |]
      )
    )
    :}
    sample
    key: &lt;a&gt;,
    key: b,

    >>> :{
    putStr $ renderMarkup (
      let as = ["<a>", "b"]
      in $(compileHtmlFileWith "templates/sample.txt" $ do
        overwrite "as" [| ["foo", "bar"] |]
      )
    )
    :}
    sample
    key: foo,
    key: bar,

    >>> :{
    putStr $ renderMarkup (
      let as = ["<a>", "b"]
      in $(compileHtmlFileWith "templates/sample.txt" $ do
        overwrite "as" [| ["bazbaz", "barbar"] |]
        setDefault "as" [| ["foo", "bar"] |]
        overwrite "as" [| ["baz", "foobar"] |]
      )
    )
    :}
    sample
    key: baz,
    key: foobar,
     -}
    compileHtmlFileWith :: FilePath -> ScopeM () -> Q Exp
    compileHtmlFileWith fp scopeM = compileFileWith scopeM htmlSetting fp

    {-| Same as 'compileHtmlFile' but allows the user to specify default values for template parameters.

    >>> :set -XOverloadedStrings
    :{
    putStr $ renderMarkup (
      let as = ["<a>", "b"]
      in $(compileHtmlFileWithDefault "templates/sample.txt"
        [("as", [| ["foo", "bar"] |])]
      )
    )
    :}
    sample
    key: &lt;a&gt;,
    key: b,

    >>> :{
    putStr $ renderMarkup (
      $(compileHtmlFileWithDefault "templates/sample.txt"
        [("as", [| ["foo", "bar"] |])]
      )
    )
    :}
    sample
    key: foo,
    key: bar,
     -}
    compileHtmlFileWithDefault :: FilePath -> DefaultScope -> Q Exp
    compileHtmlFileWithDefault fp scope = compileFileWithDefault scope htmlSetting fp

    {-| Heterocephalus quasi-quoter.
      This function __DOES NOT__ escape template variables.
      To render the compiled file, use @'Text.Blaze.Renderer'.*.renderMarkup@.

      >>> renderMarkup (let as = ["<a>", "b"] in [compileText|sample %{ forall a <- as }key: #{a}, %{ endforall }|])
      "sample key: <a>, key: b, "

      >>> renderMarkup (let num=2 in [compileText|#{num} is %{ if even num }an even number.%{ elseif (num > 100) }big.%{ else }an odd number.%{ endif }|])
      "2 is an even number."
     -}
    compileText :: QuasiQuoter
    compileText = compile textSetting

    {-| Heterocephalus quasi-quoter for HTML.
      Same as 'compileText' but this function does escape template variables in HTML.

      >>> renderMarkup (let as = ["<a>", "b"] in [compileHtml|sample %{ forall a <- as }key: #{a}, %{ endforall }|])
      "sample key: &lt;a&gt;, key: b, "
     -}
    compileHtml :: QuasiQuoter
    compileHtml = compile htmlSetting

    compile :: HeterocephalusSetting -> QuasiQuoter
    compile = compileWithDefault []

    {-| QuasiQuoter.
     -}
    compileWith :: ScopeM () -> HeterocephalusSetting -> QuasiQuoter
    compileWith scopeM set =
      QuasiQuoter
      { quoteExp = compileFromStringWith scopeM set
      , quotePat = error "not used"
      , quoteType = error "not used"
      , quoteDec = error "not used"
      }

    {-| QuasiQuoter.
     -}
    compileWithDefault :: DefaultScope -> HeterocephalusSetting -> QuasiQuoter
    compileWithDefault scope set =
      QuasiQuoter
      { quoteExp = compileFromStringWithDefault scope set
      , quotePat = error "not used"
      , quoteType = error "not used"
      , quoteDec = error "not used"
      }

    {-| Compile a template file.
    -}
    compileFile :: HeterocephalusSetting -> FilePath -> Q Exp
    compileFile = compileFileWithDefault []

    {-| Same as 'compileFile' but we can specify default scope.
    -}
    compileFileWith :: ScopeM () -> HeterocephalusSetting -> FilePath -> Q Exp
    compileFileWith scopeM set fp = do
      qAddDependentFile fp
      contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
      compileFromStringWith scopeM set contents

    {-| Same as 'compileFile' but we can specify default scope.
    -}
    compileFileWithDefault :: DefaultScope -> HeterocephalusSetting -> FilePath -> Q Exp
    compileFileWithDefault scope' set fp = do
      qAddDependentFile fp
      contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp
      compileFromStringWithDefault scope' set contents

    {-| Same as 'compileFile', but just compile the 'String' given.

      >>> let as = ["<a>", "b"]
      >>> let template = "sample %{ forall a <- as }key: #{a}, %{ endforall }"
      >>> renderMarkup $(compileFromString textSetting template)
      "sample key: <a>, key: b, "

      >>> let as = ["<a>", "b"]
      >>> let options = createParseOptions '|' '?'
      >>> let setting = textSetting { parseOptions = options }
      >>> let template = "sample |{ forall a <- as }key: ?{a}, |{ endforall }"
      >>> renderMarkup $(compileFromString setting template)
      "sample key: <a>, key: b, "
    -}
    compileFromString :: HeterocephalusSetting -> String -> Q Exp
    compileFromString = compileFromStringWithDefault []

    compileFromStringWith :: ScopeM () -> HeterocephalusSetting -> String -> Q Exp
    compileFromStringWith scopeM set s = do
      defScope' <-
        forM defScope $ \(ident, qexp) -> (ident, ) <$> overwriteScope ident qexp
      owScope' <-
        forM owScope $ \(ident, qexp) -> (ident, ) <$> qexp
      docsToExp set (owScope' ++ defScope') $ docFromString (parseOptions set) s
     where
      (defDList, owDList) = runScopeM scopeM
      defScope = DList.toList defDList
      owScope = DList.toList owDList

    compileFromStringWithDefault :: DefaultScope -> HeterocephalusSetting -> String -> Q Exp
    compileFromStringWithDefault scope' set s = do
      scope <-
        forM scope' $ \(ident, qexp) -> (ident, ) <$> overwriteScope ident qexp
      docsToExp set scope $ docFromString (parseOptions set) s

    overwriteScope :: Ident -> Q Exp -> Q Exp
    overwriteScope (Ident str) qexp = do
      mName <- lookupValueName str
      case mName of
        Just x -> varE x
        Nothing -> qexp

    {-| Settings that are used when processing heterocephalus templates.
     -}
    data HeterocephalusSetting = HeterocephalusSetting
      { escapeExp :: Q Exp
      -- ^ Template variables are passed to 'escapeExp' in the output.  This allows
      -- things like escaping HTML entities.  (See 'htmlSetting'.)
      , parseOptions :: ParseOptions
      }

    {-| A setting that escapes template variables for Html

    This sets 'escapeExp' to 'toHtml'.
     -}
    htmlSetting :: HeterocephalusSetting
    htmlSetting = HeterocephalusSetting
      { escapeExp = [|toHtml|]
      , parseOptions = defaultParseOptions
      }

    {-| A setting that DOES NOT escape template variables.

    This sets 'escapeExp' to 'preEscapedToMarkup'.
     -}
    textSetting :: HeterocephalusSetting
    textSetting = HeterocephalusSetting
      { escapeExp = [|preEscapedToMarkup|]
      , parseOptions = defaultParseOptions
      }

    type DefaultScope = [(Ident, Q Exp)]

    type DefaultDList = DList (Ident, Q Exp)
    type OverwriteDList = DList (Ident, Q Exp)

    {- | A type to handle extra scopes.
       This is opaque type, so use 'setDefault' and 'overwrite'
       to construct new 'ScopeM'.
     -}
    data ScopeM a
      = SetDefault Ident ExpQ (ScopeM a)
      | Overwrite Ident ExpQ (ScopeM a)
      | PureScopeM a

    {- | Get default values and values to overwrite from 'ScopeM'.
     -}
    runScopeM :: ScopeM a -> (DefaultDList, OverwriteDList)
    runScopeM (SetDefault ident qexp next) =
      let (defaults, overwrites) = runScopeM next
      in (DList.snoc defaults (ident, qexp), overwrites)
    runScopeM (Overwrite ident qexp next) =
      let (defaults, overwrites) = runScopeM next
      in (defaults, DList.snoc overwrites (ident, qexp))
    runScopeM (PureScopeM _) =
      (mempty, mempty)

    instance Sem.Semigroup (ScopeM ()) where
      a <> b  = a >> b

    instance Monoid (ScopeM ()) where
      mempty = pure ()
    #if !(MIN_VERSION_base(4,11,0))
      mappend = (Sem.<>)
    #endif

    instance Functor ScopeM where
      fmap f (SetDefault ident qexp next) =
        SetDefault ident qexp $ fmap f next
      fmap f (Overwrite ident qexp next) =
        Overwrite ident qexp $ fmap f next
      fmap f (PureScopeM x) =
        PureScopeM $ f x

    instance Applicative ScopeM where
      pure = PureScopeM
      SetDefault ident qexp next <*> f =
        SetDefault ident qexp $ next <*> f
      Overwrite ident qexp next <*> f =
        Overwrite ident qexp $ next <*> f
      PureScopeM g <*> f = f >>= (PureScopeM . g)

    instance Monad ScopeM where
    #if MIN_VERSION_base(4,9,0)
    #else
      return = PureScopeM
    #endif
      SetDefault ident qexp next >>= f = SetDefault ident qexp $ next >>= f
      Overwrite ident qexp next >>= f = Overwrite ident qexp $ next >>= f
      PureScopeM a >>= f = f a

    {-| Constructor for 'ScopeM'.
      Values declared by this function are overwritten
      by same name variables exits in scope of render function.
     -}
    setDefault :: Ident -> Q Exp -> ScopeM ()
    setDefault ident qexp = SetDefault ident qexp $ pure ()

    {-| Constructor for 'ScopeM'.
      Values declared by this function overwrites
      same name variables exits in scope of render function.
     -}
    overwrite :: Ident -> Q Exp -> ScopeM ()
    overwrite ident qexp = Overwrite ident qexp $ pure ()

    instance IsString Ident where
      fromString = Ident

    -- ==============================================
    --  Helper functions
    -- ==============================================

    docsToExp :: HeterocephalusSetting -> Scope -> [Doc] -> Q Exp
    docsToExp set scope docs = do
      exps <- mapM (docToExp set scope) docs
      case exps of
        [] -> [|return ()|]
        [x] -> return x
        _ -> return $ DoE $ map NoBindS exps

    docToExp :: HeterocephalusSetting -> Scope -> Doc -> Q Exp
    docToExp set scope (DocForall list idents inside) = do
      let list' = derefToExp scope list
      (pat, extraScope) <- bindingPattern idents
      let scope' = extraScope ++ scope
      mh <- [|F.mapM_|]
      inside' <- docsToExp set scope' inside
      let lam = LamE [pat] inside'
      return $ mh `AppE` lam `AppE` list'
    docToExp set scope (DocCond conds final) = do
      conds' <- mapM go conds
      final' <-
        case final of
          Nothing -> [|Nothing|]
          Just f -> do
            f' <- docsToExp set scope f
            j <- [|Just|]
            return $ j `AppE` f'
      ch <- [|condH|]
      return $ ch `AppE` ListE conds' `AppE` final'
      where
        go :: (Deref, [Doc]) -> Q Exp
        go (d, docs) = do
          let d' = derefToExp ((specialOrIdent, VarE 'or) : scope) d
          docs' <- docsToExp set scope docs
          return $ TupE [d', docs']
    docToExp set scope (DocCase deref cases) = do
        let exp_ = derefToExp scope deref
        matches <- mapM toMatch cases
        return $ CaseE exp_ matches
      where
        toMatch :: (Binding, [Doc]) -> Q Match
        toMatch (idents, inside) = do
            (pat, extraScope) <- bindingPattern idents
            let scope' = extraScope ++ scope
            insideExp <- docsToExp set scope' inside
            return $ Match pat (NormalB insideExp) []
    docToExp set v (DocContent c) = contentToExp set v c

    contentToExp :: HeterocephalusSetting -> Scope -> Content -> Q Exp
    contentToExp _ _ (ContentRaw s) = do
      os <- [|preEscapedText . pack|]
      let s' = LitE $ StringL s
      return $ os `AppE` s'
    contentToExp set scope (ContentVar d) = do
      str <- escapeExp set
      return $ str `AppE` derefToExp scope d

    -- ==============================================
    -- Codes from Text.Hamlet that is not exposed
    -- ==============================================

    unIdent :: Ident -> String
    unIdent (Ident s) = s

    bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])
    bindingPattern (BindAs i@(Ident s) b) = do
      name <- newName s
      (pattern, scope) <- bindingPattern b
      return (AsP name pattern, (i, VarE name) : scope)
    bindingPattern (BindVar i@(Ident s))
      | s == "_" = return (WildP, [])
      | all isDigit s = do return (LitP $ IntegerL $ read s, [])
      | otherwise = do
        name <- newName s
        return (VarP name, [(i, VarE name)])
    bindingPattern (BindTuple is) = do
      (patterns, scopes) <- fmap unzip $ mapM bindingPattern is
      return (TupP patterns, concat scopes)
    bindingPattern (BindList is) = do
      (patterns, scopes) <- fmap unzip $ mapM bindingPattern is
      return (ListP patterns, concat scopes)
    bindingPattern (BindConstr con is) = do
      (patterns, scopes) <- fmap unzip $ mapM bindingPattern is
      return (ConP (mkConName con) patterns, concat scopes)
    bindingPattern (BindRecord con fields wild) = do
      let f (Ident field, b) = do
            (p, s) <- bindingPattern b
            return ((mkName field, p), s)
      (patterns, scopes) <- fmap unzip $ mapM f fields
      (patterns1, scopes1) <-
        if wild
          then bindWildFields con $ map fst fields
          else return ([], [])
      return
        (RecP (mkConName con) (patterns ++ patterns1), concat scopes ++ scopes1)

    mkConName :: DataConstr -> Name
    mkConName = mkName . conToStr

    conToStr :: DataConstr -> String
    conToStr (DCUnqualified (Ident x)) = x
    conToStr (DCQualified (Module xs) (Ident x)) = intercalate "." $ xs ++ [x]

    -- Wildcards bind all of the unbound fields to variables whose name
    -- matches the field name.
    --
    -- For example: data R = C { f1, f2 :: Int }
    -- C {..}           is equivalent to   C {f1=f1, f2=f2}
    -- C {f1 = a, ..}   is equivalent to   C {f1=a,  f2=f2}
    -- C {f2 = a, ..}   is equivalent to   C {f1=f1, f2=a}
    bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
    bindWildFields conName fields = do
      fieldNames <- recordToFieldNames conName
      let available n = nameBase n `notElem` map unIdent fields
      let remainingFields = filter available fieldNames
      let mkPat n = do
            e <- newName (nameBase n)
            return ((n, VarP e), (Ident (nameBase n), VarE e))
      fmap unzip $ mapM mkPat remainingFields

    -- Important note! reify will fail if the record type is defined in the
    -- same module as the reify is used. This means quasi-quoted Hamlet
    -- literals will not be able to use wildcards to match record types
    -- defined in the same module.
    recordToFieldNames :: DataConstr -> Q [Name]
    recordToFieldNames conStr
      -- use 'lookupValueName' instead of just using 'mkName' so we reify the
      -- data constructor and not the type constructor if their names match.
     = do
      Just conName <- lookupValueName $ conToStr conStr
    #if MIN_VERSION_template_haskell(2,11,0)
      DataConI _ _ typeName         <- reify conName
      TyConI (DataD _ _ _ _ cons _) <- reify typeName
    #else
      DataConI _ _ typeName _     <- reify conName
      TyConI (DataD _ _ _ cons _) <- reify typeName
    #endif
      [fields] <- return [fields | RecC name fields <- cons, name == conName]
      return [fieldName | (fieldName, _, _) <- fields]

    type QueryParameters = [(Text, Text)]

    data VarExp msg url
      = EPlain Html
      | EUrl url
      | EUrlParam (url, QueryParameters)
      | EMixin (HtmlUrl url)
      | EMixinI18n (HtmlUrlI18n msg url)
      | EMsg msg

    instance Show (VarExp msg url) where
      show (EPlain _) = "EPlain"
      show (EUrl _) = "EUrl"
      show (EUrlParam _) = "EUrlParam"
      show (EMixin _) = "EMixin"
      show (EMixinI18n _) = "EMixinI18n"
      show (EMsg _) = "EMsg"