content: {-# LANGUAGE BangPatterns               #-}
  {-# LANGUAGE CPP                        #-}
  {-# LANGUAGE DeriveDataTypeable         #-}
  {-# LANGUAGE ExistentialQuantification  #-}
  {-# LANGUAGE FlexibleInstances          #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE MultiParamTypeClasses      #-}
  {-# LANGUAGE ScopedTypeVariables        #-}
  {-# LANGUAGE TypeFamilies               #-}
  {-# LANGUAGE UndecidableInstances       #-}
  
  {-|
  
  This module contains the core Heist data types.
  
  Edward Kmett wrote most of the HeistT monad code and associated instances,
  liberating us from the unused writer portion of RWST.
  
  -}
  
  module Heist.Internal.Types.HeistState where
  
  ------------------------------------------------------------------------------
  import           Blaze.ByteString.Builder      (Builder)
  import           Control.Applicative           (Alternative (..))
  import           Control.Arrow                 (first)
  import           Control.Exception             (Exception)
  import           Control.Monad                 (MonadPlus (..), ap)
  import           Control.Monad.Base
  import           Control.Monad.Cont            (MonadCont (..))
  #if MIN_VERSION_mtl(2,2,1)
  import           Control.Monad.Except          (MonadError (..))
  #else
  import           Control.Monad.Error           (MonadError (..))
  #endif
  #if MIN_VERSION_base(4,9,0)
  import qualified Control.Monad.Fail as Fail
  #endif
  import           Control.Monad.Fix             (MonadFix (..))
  import           Control.Monad.Reader          (MonadReader (..))
  import           Control.Monad.State.Strict    (MonadState (..), StateT)
  import           Control.Monad.Trans           (MonadIO (..), MonadTrans (..))
  import           Control.Monad.Trans.Control
  import           Data.ByteString.Char8         (ByteString)
  import           Data.DList                    (DList)
  import           Data.HashMap.Strict           (HashMap)
  import qualified Data.HashMap.Strict           as H
  import           Data.HeterogeneousEnvironment (HeterogeneousEnvironment)
  import qualified Data.HeterogeneousEnvironment as HE
  import           Data.Map.Syntax
  #if !MIN_VERSION_base(4,11,0)
  import           Data.Semigroup
  #endif
  import           Data.Text                     (Text)
  import qualified Data.Text                     as T
  import           Data.Text.Encoding            (decodeUtf8)
  #if MIN_VERSION_base (4,7,0)
  import           Data.Typeable                 (Typeable)
  #else
  import           Data.Typeable                 (TyCon, Typeable(..),
                                                  Typeable1(..), mkTyCon,
                                                  mkTyConApp)
  #endif
  
  #if !MIN_VERSION_base(4,8,0)
  import           Control.Applicative           (Applicative (..), (<$>))
  import           Data.Monoid                   (Monoid(..))
  #endif
  
  import qualified Text.XmlHtml                  as X
  ------------------------------------------------------------------------------
  
  
  ------------------------------------------------------------------------------
  -- | Convenient type alies for splices.
  type Splices s = MapSyntax Text s
  
  
  ------------------------------------------------------------------------------
  -- | A 'Template' is a forest of XML nodes.  Here we deviate from the \"single
  -- root node\" constraint of well-formed XML because we want to allow
  -- templates to contain document fragments that may not have a single root.
  type Template = [X.Node]
  
  
  ------------------------------------------------------------------------------
  -- | MIME Type.  The type alias is here to make the API clearer.
  type MIMEType = ByteString
  
  
  ------------------------------------------------------------------------------
  -- | Reversed list of directories.  This holds the path to the template
  -- currently being processed.
  type TPath = [ByteString]
  
  
  ------------------------------------------------------------------------------
  -- | Holds data about templates read from disk.
  data DocumentFile = DocumentFile
      { dfDoc  :: X.Document
      , dfFile :: Maybe FilePath
      } deriving ( Eq, Show
  #if MIN_VERSION_base(4,7,0)
                 , Typeable
  #endif
                 )
  
  
  ------------------------------------------------------------------------------
  -- | Designates whether a document should be treated as XML or HTML.
  data Markup = Xml | Html
  
  
  ------------------------------------------------------------------------------
  -- | Monad used for runtime splice execution.
  newtype RuntimeSplice m a = RuntimeSplice {
        unRT :: StateT HeterogeneousEnvironment m a
      } deriving ( Applicative
                 , Functor
                 , Monad
                 , MonadIO
                 , MonadState HeterogeneousEnvironment
                 , MonadTrans
  #if MIN_VERSION_base(4,7,0)
                 , Typeable
  #endif
                 )
  
  
  ------------------------------------------------------------------------------
  instance (Monad m, Semigroup a) => Semigroup (RuntimeSplice m a) where
      a <> b = do
          !x <- a
          !y <- b
          return $! x <> y
  
  
  #if !MIN_VERSION_base(4,11,0)
  instance (Monad m, Semigroup a, Monoid a) => Monoid (RuntimeSplice m a) where
  #else
  instance (Monad m, Monoid a) => Monoid (RuntimeSplice m a) where
  #endif
      mempty = return mempty
  #if !MIN_VERSION_base(4,11,0)
      mappend = (<>)
  #endif
  
  
  ------------------------------------------------------------------------------
  -- | Opaque type representing pieces of output from compiled splices.
  data Chunk m = Pure !ByteString
                 -- ^ output known at load time
               | RuntimeHtml !(RuntimeSplice m Builder)
                 -- ^ output computed at run time
               | RuntimeAction !(RuntimeSplice m ())
                 -- ^ runtime action used only for its side-effect
  #if MIN_VERSION_base(4,7,0)
               deriving Typeable
  #endif
  
  instance Show (Chunk m) where
      show (Pure _) = "Pure"
      show (RuntimeHtml _) = "RuntimeHtml"
      show (RuntimeAction _) = "RuntimeAction"
  
  
  showChunk :: Chunk m -> String
  showChunk (Pure b) = T.unpack $ decodeUtf8 b
  showChunk (RuntimeHtml _) = "RuntimeHtml"
  showChunk (RuntimeAction _) = "RuntimeAction"
  
  
  isPureChunk :: Chunk m -> Bool
  isPureChunk (Pure _) = True
  isPureChunk _ = False
  
  
  ------------------------------------------------------------------------------
  -- | Type alias for attribute splices.  The function parameter is the value of
  -- the bound attribute splice.  The return value is a list of attribute
  -- key/value pairs that get substituted in the place of the bound attribute.
  type AttrSplice m = Text -> RuntimeSplice m [(Text, Text)]
  
  
  ------------------------------------------------------------------------------
  -- | Detailed information about a splice error.
  data SpliceError = SpliceError
      { spliceHistory      :: [(TPath, Maybe FilePath, Text)]
      , spliceTemplateFile :: Maybe FilePath
      , visibleSplices     :: [Text]
      , contextNode        :: X.Node
      , spliceMsg          :: Text
      } deriving ( Show, Eq )
  
  
  ------------------------------------------------------------------------------
  -- | Transform a SpliceError record to a Text message.
  spliceErrorText :: SpliceError -> Text
  spliceErrorText (SpliceError hist tf splices node msg) =
      (maybe "" ((`mappend` ": ") . T.pack) tf) `T.append` msg `T.append`
      foldr (\(_, tf', tag) -> (("\n   ... via " `T.append`
                                 (maybe "" ((`mappend` ": ") . T.pack) tf')
                                 `T.append` tag) `T.append`)) T.empty hist
      `T.append`
      if null splices
        then T.empty
        else "\nBound splices:" `T.append`
           foldl (\x y -> x `T.append` " " `T.append` y) T.empty splices
      `T.append`
      (T.pack $ "\nNode: " ++ (show node))
  
  
  ------------------------------------------------------------------------------
  -- | Exception type for splice compile errors.  Wraps the original
  -- exception and provides context.
  --data (Exception e) => CompileException e = CompileException
  data CompileException = forall e . Exception e => CompileException
      { originalException :: e
      -- The list of splice errors.  The head of it has the context
      -- related to the exception.
      , exceptionContext :: [SpliceError]
      } deriving ( Typeable )
  
  
  instance Show CompileException where
      show (CompileException e []) =
        "Heist load exception (unknown context): " ++ (show e)
      show (CompileException _ (c:_)) = (T.unpack $ spliceErrorText c)
  
  
  instance Exception CompileException
  
  
  ------------------------------------------------------------------------------
  -- | Holds all the state information needed for template processing.  You will
  -- build a @HeistState@ using 'initHeist' and any of Heist's @HeistState ->
  -- HeistState@ \"filter\" functions.  Then you use the resulting @HeistState@
  -- in calls to 'renderTemplate'.
  --
  -- m is the runtime monad
  data HeistState m = HeistState {
      -- | A mapping of splice names to splice actions
        _spliceMap           :: HashMap Text (HeistT m m Template)
      -- | A mapping of template names to templates
      , _templateMap         :: HashMap TPath DocumentFile
  
      -- | A mapping of splice names to splice actions
      , _compiledSpliceMap   :: HashMap Text (HeistT m IO (DList (Chunk m)))
      -- | A mapping of template names to templates
      --, _compiledTemplateMap :: HashMap TPath (m Builder, MIMEType)
      , _compiledTemplateMap :: !(HashMap TPath ([Chunk m], MIMEType))
  
      , _attrSpliceMap       :: HashMap Text (AttrSplice m)
  
      -- | A flag to control splice recursion
      , _recurse             :: Bool
      -- | The path to the template currently being processed.
      , _curContext          :: TPath
      -- | Stack of the splices used.
      , _splicePath          :: [(TPath, Maybe FilePath, Text)]
      -- | A counter keeping track of the current recursion depth to prevent
      -- infinite loops.
      , _recursionDepth      :: Int
      -- | The doctypes encountered during template processing.
      , _doctypes            :: [X.DocType]
      -- | The full path to the current template's file on disk.
      , _curTemplateFile     :: Maybe FilePath
      -- | A key generator used to produce new unique Promises.
      , _keygen              :: HE.KeyGen
  
      -- | Flag indicating whether we're in preprocessing mode.  During
      -- preprocessing, errors should stop execution and be reported.  During
      -- template rendering, it's better to skip the errors and render the page.
      , _preprocessingMode   :: Bool
  
      -- | This is needed because compiled templates are generated with a bunch
      -- of calls to renderFragment rather than a single call to render.
      , _curMarkup           :: Markup
  
      -- | A prefix for all splices (namespace ++ ":").
      , _splicePrefix        :: Text
  
      -- | List of errors encountered during splice processing.
      , _spliceErrors        :: [SpliceError]
  
      -- | Whether to throw an error when a tag wih the heist namespace does not
      -- correspond to a bound splice.  When not using a namespace, this flag is
      -- ignored.
      , _errorNotBound       :: Bool
      , _numNamespacedTags   :: Int
  #if MIN_VERSION_base(4,7,0)
  } deriving (Typeable)
  #else
  }
  #endif
  
  #if !MIN_VERSION_base(4,7,0)
  -- NOTE: We got rid of the Monoid instance because it is absolutely not safe
  -- to combine two compiledTemplateMaps.  All compiled templates must be known
  -- at load time and processed in a single call to initHeist/loadTemplates or
  -- whatever we end up calling it..
  
  instance (Typeable1 m) => Typeable (HeistState m) where
      typeOf _ = mkTyConApp templateStateTyCon [typeOf1 (undefined :: m ())]
  
  #endif
  
  ------------------------------------------------------------------------------
  -- | HeistT is the monad transformer used for splice processing.  HeistT
  -- intentionally does not expose any of its functionality via MonadState or
  -- MonadReader functions.  We define passthrough instances for the most common
  -- types of monads.  These instances allow the user to use HeistT in a monad
  -- stack without needing calls to `lift`.
  --
  -- @n@ is the runtime monad (the parameter to HeistState).
  --
  -- @m@ is the monad being run now.  In this case, \"now\" is a variable
  -- concept.  The type @HeistT n n@ means that \"now\" is runtime.  The type
  -- @HeistT n IO@ means that \"now\" is @IO@, and more importantly it is NOT
  -- runtime. In Heist, the rule of thumb is that @IO@ means load time and @n@
  -- means runtime.
  newtype HeistT n m a = HeistT {
      runHeistT :: X.Node
                -> HeistState n
                -> m (a, HeistState n)
  #if MIN_VERSION_base(4,7,0)
  } deriving Typeable
  #else
  }
  #endif
  
  
  ------------------------------------------------------------------------------
  -- | Gets the names of all the templates defined in a HeistState.
  templateNames :: HeistState m -> [TPath]
  templateNames ts = H.keys $ _templateMap ts
  
  
  ------------------------------------------------------------------------------
  -- | Gets the names of all the templates defined in a HeistState.
  compiledTemplateNames :: HeistState m -> [TPath]
  compiledTemplateNames ts = H.keys $ _compiledTemplateMap ts
  
  
  ------------------------------------------------------------------------------
  -- | Gets the names of all the interpreted splices defined in a HeistState.
  spliceNames :: HeistState m -> [Text]
  spliceNames ts = H.keys $ _spliceMap ts
  
  
  ------------------------------------------------------------------------------
  -- | Gets the names of all the compiled splices defined in a HeistState.
  compiledSpliceNames :: HeistState m -> [Text]
  compiledSpliceNames ts = H.keys $ _compiledSpliceMap ts
  
  
  #if !MIN_VERSION_base(4,7,0)
  ------------------------------------------------------------------------------
  -- | The Typeable instance is here so Heist can be dynamically executed with
  -- Hint.
  templateStateTyCon :: TyCon
  templateStateTyCon = mkTyCon "Heist.HeistState"
  {-# NOINLINE templateStateTyCon #-}
  #endif
  
  
  ------------------------------------------------------------------------------
  -- | Evaluates a template monad as a computation in the underlying monad.
  evalHeistT :: (Monad m)
             => HeistT n m a
             -> X.Node
             -> HeistState n
             -> m a
  evalHeistT m r s = do
      (a, _) <- runHeistT m r s
      return a
  {-# INLINE evalHeistT #-}
  
  
  ------------------------------------------------------------------------------
  -- | Functor instance
  instance Functor m => Functor (HeistT n m) where
      fmap f (HeistT m) = HeistT $ \r s -> first f <$> m r s
  
  
  ------------------------------------------------------------------------------
  -- | Applicative instance
  instance (Monad m, Functor m) => Applicative (HeistT n m) where
      pure = return
      (<*>) = ap
  
  
  ------------------------------------------------------------------------------
  -- | Monad instance
  instance Monad m => Monad (HeistT n m) where
      return a = HeistT (\_ s -> return (a, s))
      {-# INLINE return #-}
      HeistT m >>= k = HeistT $ \r s -> do
          (a, s') <- m r s
          runHeistT (k a) r s'
      {-# INLINE (>>=) #-}
  
  
  #if MIN_VERSION_base(4,9,0)
  ------------------------------------------------------------------------------
  -- | MonadFail instance
  instance Fail.MonadFail m => Fail.MonadFail (HeistT n m) where
      fail = lift . Fail.fail
  #endif
  
  
  ------------------------------------------------------------------------------
  -- | MonadIO instance
  instance MonadIO m => MonadIO (HeistT n m) where
      liftIO = lift . liftIO
  
  
  ------------------------------------------------------------------------------
  -- | MonadTrans instance
  instance MonadTrans (HeistT n) where
      lift m = HeistT $ \_ s -> do
          a <- m
          return (a, s)
  
  
  instance MonadBase b m => MonadBase b (HeistT n m) where
      liftBase = lift . liftBase
  
  #if MIN_VERSION_monad_control(1,0,0)
  instance MonadTransControl (HeistT n) where
      type StT (HeistT n) a = (a, HeistState n)
      liftWith f = HeistT $ \n s -> do
          res <- f $ \(HeistT g) -> g n s
          return (res, s)
      restoreT k = HeistT $ \_ _ -> k
      {-# INLINE liftWith #-}
      {-# INLINE restoreT #-}
  
  
  instance MonadBaseControl b m => MonadBaseControl b (HeistT n m) where
       type StM (HeistT n m) a = ComposeSt (HeistT n) m a
       liftBaseWith = defaultLiftBaseWith
       restoreM = defaultRestoreM
       {-# INLINE liftBaseWith #-}
       {-# INLINE restoreM #-}
  #else
  instance MonadTransControl (HeistT n) where
      newtype StT (HeistT n) a = StHeistT {unStHeistT :: (a, HeistState n)}
      liftWith f = HeistT $ \n s -> do
          res <- f $ \(HeistT g) -> liftM StHeistT $ g n s
          return (res, s)
      restoreT k = HeistT $ \_ _ -> liftM unStHeistT k
      {-# INLINE liftWith #-}
      {-# INLINE restoreT #-}
  
  
  instance MonadBaseControl b m => MonadBaseControl b (HeistT n m) where
       newtype StM (HeistT n m) a = StMHeist {unStMHeist :: ComposeSt (HeistT n) m a}
       liftBaseWith = defaultLiftBaseWith StMHeist
       restoreM = defaultRestoreM unStMHeist
       {-# INLINE liftBaseWith #-}
       {-# INLINE restoreM #-}
  #endif
  
  ------------------------------------------------------------------------------
  -- | MonadFix passthrough instance
  instance MonadFix m => MonadFix (HeistT n m) where
      mfix f = HeistT $ \r s ->
          mfix $ \ (a, _) -> runHeistT (f a) r s
  
  
  ------------------------------------------------------------------------------
  -- | Alternative passthrough instance
  instance (Functor m, MonadPlus m) => Alternative (HeistT n m) where
      empty = mzero
      (<|>) = mplus
  
  
  ------------------------------------------------------------------------------
  -- | MonadPlus passthrough instance
  instance MonadPlus m => MonadPlus (HeistT n m) where
      mzero = lift mzero
      m `mplus` n = HeistT $ \r s ->
          runHeistT m r s `mplus` runHeistT n r s
  
  
  ------------------------------------------------------------------------------
  -- | MonadState passthrough instance
  instance MonadState s m => MonadState s (HeistT n m) where
      get = lift get
      {-# INLINE get #-}
      put = lift . put
      {-# INLINE put #-}
  
  
  ------------------------------------------------------------------------------
  -- | MonadReader passthrough instance
  instance MonadReader r m => MonadReader r (HeistT n m) where
      ask = HeistT $ \_ s -> do
              r <- ask
              return (r,s)
      local f (HeistT m) =
          HeistT $ \r s -> local f (m r s)
  
  
  ------------------------------------------------------------------------------
  -- | Helper for MonadError instance.
  _liftCatch
      :: (m (a,HeistState n)
          -> (e -> m (a,HeistState n))
          -> m (a,HeistState n))
      -> HeistT n m a
      -> (e -> HeistT n m a)
      -> HeistT n m a
  _liftCatch ce m h =
      HeistT $ \r s ->
          (runHeistT m r s `ce`
          (\e -> runHeistT (h e) r s))
  
  
  ------------------------------------------------------------------------------
  -- | MonadError passthrough instance
  instance (MonadError e m) => MonadError e (HeistT n m) where
      throwError = lift . throwError
      catchError = _liftCatch catchError
  
  
  ------------------------------------------------------------------------------
  -- | Helper for MonadCont instance.
  _liftCallCC
      :: ((((a,HeistState n) -> m (b, HeistState n))
             -> m (a, HeistState n))
           -> m (a, HeistState n))
      -> ((a -> HeistT n m b) -> HeistT n m a)
      -> HeistT n m a
  _liftCallCC ccc f = HeistT $ \r s ->
      ccc $ \c ->
      runHeistT (f (\a -> HeistT $ \_ _ -> c (a, s))) r s
  
  
  ------------------------------------------------------------------------------
  -- | MonadCont passthrough instance
  instance (MonadCont m) => MonadCont (HeistT n m) where
      callCC = _liftCallCC callCC
  
  
  #if !MIN_VERSION_base(4,7,0)
  ------------------------------------------------------------------------------
  -- | The Typeable instance is here so Heist can be dynamically executed with
  -- Hint.
  templateMonadTyCon :: TyCon
  templateMonadTyCon = mkTyCon "Heist.HeistT"
  {-# NOINLINE templateMonadTyCon #-}
  
  instance (Typeable1 m) => Typeable1 (HeistT n m) where
      typeOf1 _ = mkTyConApp templateMonadTyCon [typeOf1 (undefined :: m ())]
  #endif
  
  
  ------------------------------------------------------------------------------
  -- Functions for our monad.
  ------------------------------------------------------------------------------
  
  
  ------------------------------------------------------------------------------
  -- | Gets the node currently being processed.
  --
  --   > <speech author="Shakespeare">
  --   >   To sleep, perchance to dream.
  --   > </speech>
  --
  -- When you call @getParamNode@ inside the code for the @speech@ splice, it
  -- returns the Node for the @speech@ tag and its children.  @getParamNode >>=
  -- childNodes@ returns a list containing one 'TextNode' containing part of
  -- Hamlet's speech.  @liftM (getAttribute \"author\") getParamNode@ would
  -- return @Just \"Shakespeare\"@.
  getParamNode :: Monad m => HeistT n m X.Node
  getParamNode = HeistT $ curry return
  {-# INLINE getParamNode #-}
  
  
  ------------------------------------------------------------------------------
  -- | HeistT's 'local'.
  localParamNode :: Monad m
                 => (X.Node -> X.Node)
                 -> HeistT n m a
                 -> HeistT n m a
  localParamNode f m = HeistT $ \r s -> runHeistT m (f r) s
  {-# INLINE localParamNode #-}
  
  
  ------------------------------------------------------------------------------
  -- | HeistT's 'gets'.
  getsHS :: Monad m => (HeistState n -> r) -> HeistT n m r
  getsHS f = HeistT $ \_ s -> return (f s, s)
  {-# INLINE getsHS #-}
  
  
  ------------------------------------------------------------------------------
  -- | HeistT's 'get'.
  getHS :: Monad m => HeistT n m (HeistState n)
  getHS = HeistT $ \_ s -> return (s, s)
  {-# INLINE getHS #-}
  
  
  ------------------------------------------------------------------------------
  -- | HeistT's 'put'.
  putHS :: Monad m => HeistState n -> HeistT n m ()
  putHS s = HeistT $ \_ _ -> return ((), s)
  {-# INLINE putHS #-}
  
  
  ------------------------------------------------------------------------------
  -- | HeistT's 'modify'.
  modifyHS :: Monad m
           => (HeistState n -> HeistState n)
           -> HeistT n m ()
  modifyHS f = HeistT $ \_ s -> return ((), f s)
  {-# INLINE modifyHS #-}
  
  
  ------------------------------------------------------------------------------
  -- | Restores the HeistState.  This function is almost like putHS except it
  -- preserves the current doctypes and splice errors.  You should use this
  -- function instead of @putHS@ to restore an old state.  This was needed
  -- because doctypes needs to be in a "global scope" as opposed to the template
  -- call "local scope" of state items such as recursionDepth, curContext, and
  -- spliceMap.
  restoreHS :: Monad m => HeistState n -> HeistT n m ()
  restoreHS old = modifyHS (\cur -> old { _doctypes = _doctypes cur
                                        , _numNamespacedTags =
                                          _numNamespacedTags cur
                                        , _spliceErrors = _spliceErrors cur })
  {-# INLINE restoreHS #-}
  
  
  ------------------------------------------------------------------------------
  -- | Abstracts the common pattern of running a HeistT computation with
  -- a modified heist state.
  localHS :: Monad m
          => (HeistState n -> HeistState n)
          -> HeistT n m a
          -> HeistT n m a
  localHS f k = do
      ts <- getHS
      putHS $ f ts
      res <- k
      restoreHS ts
      return res
  {-# INLINE localHS #-}
  
  
  ------------------------------------------------------------------------------
  -- | Modifies the recursion depth.
  modRecursionDepth :: Monad m => (Int -> Int) -> HeistT n m ()
  modRecursionDepth f =
      modifyHS (\st -> st { _recursionDepth = f (_recursionDepth st) })
  
  
  ------------------------------------------------------------------------------
  -- | Increments the namespaced tag count
  incNamespacedTags :: Monad m => HeistT n m ()
  incNamespacedTags =
      modifyHS (\st -> st { _numNamespacedTags = _numNamespacedTags st + 1 })
  
  
  ------------------------------------------------------------------------------
  -- | AST to hold attribute parsing structure.  This is necessary because
  -- attoparsec doesn't support parsers running in another monad.
  data AttAST = Literal Text
              | Ident   Text
    deriving (Show)
  
  
  ------------------------------------------------------------------------------
  isIdent :: AttAST -> Bool
  isIdent (Ident _) = True
  isIdent _         = False
  
  
  