{-#LANGUAGE FlexibleContexts #-}
{-#LANGUAGE FlexibleInstances #-}
{-#LANGUAGE OverloadedStrings #-}
{-#LANGUAGE TupleSections #-}
{-#LANGUAGE TypeSynonymInstances #-}
{-#LANGUAGE MultiParamTypeClasses #-}
{-#LANGUAGE ScopedTypeVariables #-}

-- | The internals of the 'Run' monad, and various things needed to make the
-- magic happen. You will not normally need to import this module;
-- 'Text.Ginger.Run' re-exports the things you probably want. However, if you
-- want to provide your own run monad that extends 'Run' somehow, this module
-- may be of use.
module Text.Ginger.Run.Type
( GingerContext (..)
, makeContext
, makeContextM
, makeContext'
, makeContextM'
, makeContextExM'
, makeContextHtml
, makeContextHtmlM
, makeContextHtmlExM
, makeContextText
, makeContextTextM
, makeContextTextExM
, easyContext
, ContextEncodable (..)
, liftRun
, liftRun2
, Run (..)
, RunState (..)
, RuntimeError (..)
, runtimeErrorWhat
, runtimeErrorWhere
, runtimeErrorMessage
-- * The Newlines type
-- | Required for handling indentation
, Newlines (..)
-- * Hoisting
, hoistContext
, hoistRun
, hoistNewlines
, hoistRunState
, warn
, warnFromMaybe
, throwHere
, withSourcePos
, getSourcePos
)
where

import Prelude ( (.), ($), (==), (/=)
               , (>), (<), (>=), (<=)
               , (+), (-), (*), (/), div, (**), (^)
               , (||), (&&)
               , (++)
               , Show, show
               , undefined, otherwise
               , Maybe (..)
               , Bool (..)
               , Int, Integer, String
               , fromIntegral, floor, round
               , not
               , show
               , uncurry
               , seq
               , fst, snd
               , maybe
               , Either (..)
               , id
               )
import qualified Prelude
import Data.Maybe (fromMaybe, isJust)
import qualified Data.List as List
import Text.Ginger.AST
import Text.Ginger.Html
import Text.Ginger.GVal
import Text.Ginger.Parse (ParserError (..), sourceLine, sourceColumn, sourceName)
import Text.Printf
import Text.PrintfA
import Data.Scientific (formatScientific)
import Control.Monad.Except (ExceptT (..))
import Data.Default (Default (..), def)

import Data.Char (isSpace)
import Data.Text (Text)
import Data.String (fromString)
import qualified Data.Text as Text
import qualified Data.ByteString.UTF8 as UTF8
import Control.Monad
import Control.Monad.Identity
import Control.Monad.Writer
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Except
import Control.Applicative
import qualified Data.HashMap.Strict as HashMap
import Data.HashMap.Strict (HashMap)
import Data.Scientific (Scientific)
import Data.Scientific as Scientific
import Data.Default (def)
import Safe (readMay, lastDef, headMay)
import Network.HTTP.Types (urlEncode)
import Debug.Trace (trace)
import Data.Maybe (isNothing)
import Data.List (lookup, zipWith, unzip)

-- | Execution context. Determines how to look up variables from the
-- environment, and how to write out template output.
data GingerContext p m h
    = GingerContext
        { GingerContext p m h -> VarName -> Run p m h (GVal (Run p m h))
contextLookup :: VarName -> Run p m h (GVal (Run p m h))
        , GingerContext p m h -> h -> Run p m h ()
contextWrite :: h -> Run p m h ()
        , GingerContext p m h -> RuntimeError p -> Run p m h ()
contextWarn :: RuntimeError p -> Run p m h ()
        , GingerContext p m h -> GVal (Run p m h) -> h
contextEncode :: GVal (Run p m h) -> h
        , GingerContext p m h -> Maybe (Newlines h)
contextNewlines :: Maybe (Newlines h)
        }

-- | Hoist a context onto a different output type.
-- @hoistContext fwd rev context@ returns a context over a different
-- output type, applying the @fwd@ and @rev@ projections to convert
-- between the original and desired output types.
hoistContext :: Monad m => (h -> t) -> (t -> h) -> GingerContext p m h -> GingerContext p m t
hoistContext :: (h -> t) -> (t -> h) -> GingerContext p m h -> GingerContext p m t
hoistContext h -> t
fwd t -> h
rev GingerContext p m h
c =
    GingerContext :: forall p (m :: * -> *) h.
(VarName -> Run p m h (GVal (Run p m h)))
-> (h -> Run p m h ())
-> (RuntimeError p -> Run p m h ())
-> (GVal (Run p m h) -> h)
-> Maybe (Newlines h)
-> GingerContext p m h
GingerContext
        { contextLookup :: VarName -> Run p m t (GVal (Run p m t))
contextLookup = \VarName
varName ->
            (forall a. Run p m h a -> Run p m t a)
-> (forall a. Run p m t a -> Run p m h a)
-> GVal (Run p m h)
-> GVal (Run p m t)
forall (m :: * -> *) (n :: * -> *).
(Functor m, Functor n) =>
(forall a. m a -> n a)
-> (forall a. n a -> m a) -> GVal m -> GVal n
marshalGValEx
                ((h -> t) -> (t -> h) -> Run p m h a -> Run p m t a
forall (m :: * -> *) h t p a.
Monad m =>
(h -> t) -> (t -> h) -> Run p m h a -> Run p m t a
hoistRun h -> t
fwd t -> h
rev)
                ((t -> h) -> (h -> t) -> Run p m t a -> Run p m h a
forall (m :: * -> *) h t p a.
Monad m =>
(h -> t) -> (t -> h) -> Run p m h a -> Run p m t a
hoistRun t -> h
rev h -> t
fwd) (GVal (Run p m h) -> GVal (Run p m t))
-> ExceptT
     (RuntimeError p)
     (StateT (RunState p m t) (ReaderT (GingerContext p m t) m))
     (GVal (Run p m h))
-> Run p m t (GVal (Run p m t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                (h -> t)
-> (t -> h)
-> Run p m h (GVal (Run p m h))
-> ExceptT
     (RuntimeError p)
     (StateT (RunState p m t) (ReaderT (GingerContext p m t) m))
     (GVal (Run p m h))
forall (m :: * -> *) h t p a.
Monad m =>
(h -> t) -> (t -> h) -> Run p m h a -> Run p m t a
hoistRun h -> t
fwd t -> h
rev (GingerContext p m h -> VarName -> Run p m h (GVal (Run p m h))
forall p (m :: * -> *) h.
GingerContext p m h -> VarName -> Run p m h (GVal (Run p m h))
contextLookup GingerContext p m h
c VarName
varName)
        , contextWrite :: t -> Run p m t ()
contextWrite = \t
val ->
            (h -> t) -> (t -> h) -> Run p m h () -> Run p m t ()
forall (m :: * -> *) h t p a.
Monad m =>
(h -> t) -> (t -> h) -> Run p m h a -> Run p m t a
hoistRun h -> t
fwd t -> h
rev (GingerContext p m h -> h -> Run p m h ()
forall p (m :: * -> *) h. GingerContext p m h -> h -> Run p m h ()
contextWrite GingerContext p m h
c (h -> Run p m h ()) -> h -> Run p m h ()
forall a b. (a -> b) -> a -> b
$ t -> h
rev t
val)
        , contextWarn :: RuntimeError p -> Run p m t ()
contextWarn = \RuntimeError p
str ->
            (h -> t) -> (t -> h) -> Run p m h () -> Run p m t ()
forall (m :: * -> *) h t p a.
Monad m =>
(h -> t) -> (t -> h) -> Run p m h a -> Run p m t a
hoistRun h -> t
fwd t -> h
rev (GingerContext p m h -> RuntimeError p -> Run p m h ()
forall p (m :: * -> *) h.
GingerContext p m h -> RuntimeError p -> Run p m h ()
contextWarn GingerContext p m h
c RuntimeError p
str)
        , contextEncode :: GVal (Run p m t) -> t
contextEncode = \GVal (Run p m t)
gval ->
            h -> t
fwd (h -> t) -> (GVal (Run p m t) -> h) -> GVal (Run p m t) -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                GingerContext p m h -> GVal (Run p m h) -> h
forall p (m :: * -> *) h.
GingerContext p m h -> GVal (Run p m h) -> h
contextEncode GingerContext p m h
c (GVal (Run p m h) -> h)
-> (GVal (Run p m t) -> GVal (Run p m h)) -> GVal (Run p m t) -> h
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                (forall a. Run p m t a -> Run p m h a)
-> (forall a. Run p m h a -> Run p m t a)
-> GVal (Run p m t)
-> GVal (Run p m h)
forall (m :: * -> *) (n :: * -> *).
(Functor m, Functor n) =>
(forall a. m a -> n a)
-> (forall a. n a -> m a) -> GVal m -> GVal n
marshalGValEx ((t -> h) -> (h -> t) -> Run p m t a -> Run p m h a
forall (m :: * -> *) h t p a.
Monad m =>
(h -> t) -> (t -> h) -> Run p m h a -> Run p m t a
hoistRun t -> h
rev h -> t
fwd) ((h -> t) -> (t -> h) -> Run p m h a -> Run p m t a
forall (m :: * -> *) h t p a.
Monad m =>
(h -> t) -> (t -> h) -> Run p m h a -> Run p m t a
hoistRun h -> t
fwd t -> h
rev) (GVal (Run p m t) -> t) -> GVal (Run p m t) -> t
forall a b. (a -> b) -> a -> b
$
                GVal (Run p m t)
gval
        , contextNewlines :: Maybe (Newlines t)
contextNewlines =
            (h -> t) -> (t -> h) -> Newlines h -> Newlines t
forall h t. (h -> t) -> (t -> h) -> Newlines h -> Newlines t
hoistNewlines h -> t
fwd t -> h
rev (Newlines h -> Newlines t)
-> Maybe (Newlines h) -> Maybe (Newlines t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GingerContext p m h -> Maybe (Newlines h)
forall p (m :: * -> *) h. GingerContext p m h -> Maybe (Newlines h)
contextNewlines GingerContext p m h
c
        }

contextWriteEncoded :: GingerContext p m h -> GVal (Run p m h) -> Run p m h ()
contextWriteEncoded :: GingerContext p m h -> GVal (Run p m h) -> Run p m h ()
contextWriteEncoded GingerContext p m h
context =
    GingerContext p m h -> h -> Run p m h ()
forall p (m :: * -> *) h. GingerContext p m h -> h -> Run p m h ()
contextWrite GingerContext p m h
context (h -> Run p m h ())
-> (GVal (Run p m h) -> h) -> GVal (Run p m h) -> Run p m h ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GingerContext p m h -> GVal (Run p m h) -> h
forall p (m :: * -> *) h.
GingerContext p m h -> GVal (Run p m h) -> h
contextEncode GingerContext p m h
context

easyContext :: (Monad m, ContextEncodable h, ToGVal (Run p m h) v)
            => (h -> m ())
            -> v
            -> GingerContext p m h
easyContext :: (h -> m ()) -> v -> GingerContext p m h
easyContext h -> m ()
emit v
context =
    (h -> m ()) -> (RuntimeError p -> m ()) -> v -> GingerContext p m h
forall (m :: * -> *) h p v.
(Monad m, ContextEncodable h, ToGVal (Run p m h) v) =>
(h -> m ()) -> (RuntimeError p -> m ()) -> v -> GingerContext p m h
easyContextEx h -> m ()
emit (m () -> RuntimeError p -> m ()
forall a b. a -> b -> a
Prelude.const (m () -> RuntimeError p -> m ()) -> m () -> RuntimeError p -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) v
context

easyContextEx :: (Monad m, ContextEncodable h, ToGVal (Run p m h) v)
              => (h -> m ())
              -> (RuntimeError p -> m ())
              -> v
              -> GingerContext p m h
easyContextEx :: (h -> m ()) -> (RuntimeError p -> m ()) -> v -> GingerContext p m h
easyContextEx h -> m ()
emit RuntimeError p -> m ()
warn v
context =
    (VarName -> Run p m h (GVal (Run p m h)))
-> (h -> m ())
-> (RuntimeError p -> m ())
-> (GVal (Run p m h) -> h)
-> Maybe (Newlines h)
-> GingerContext p m h
forall (m :: * -> *) p h.
Monad m =>
(VarName -> Run p m h (GVal (Run p m h)))
-> (h -> m ())
-> (RuntimeError p -> m ())
-> (GVal (Run p m h) -> h)
-> Maybe (Newlines h)
-> GingerContext p m h
makeContextExM'
        (\VarName
varName ->
            GVal (Run p m h) -> Run p m h (GVal (Run p m h))
forall (m :: * -> *) a. Monad m => a -> m a
return
                (GVal (Run p m h)
-> GVal (Run p m h) -> GVal (Run p m h) -> GVal (Run p m h)
forall (m :: * -> *). GVal m -> GVal m -> GVal m -> GVal m
lookupLooseDef GVal (Run p m h)
forall a. Default a => a
def
                    (VarName -> GVal (Run p m h)
forall (m :: * -> *) a. ToGVal m a => a -> GVal m
toGVal VarName
varName)
                    (v -> GVal (Run p m h)
forall (m :: * -> *) a. ToGVal m a => a -> GVal m
toGVal v
context)))
        h -> m ()
emit
        RuntimeError p -> m ()
warn
        GVal (Run p m h) -> h
forall h (m :: * -> *). ContextEncodable h => GVal m -> h
encode
        Maybe (Newlines h)
forall h. ContextEncodable h => Maybe (Newlines h)
newlines


-- | Typeclass that defines how to encode 'GVal's into a given type.
class ContextEncodable h where
    encode :: forall m. GVal m -> h
    newlines :: Maybe (Newlines h)
    newlines = Maybe (Newlines h)
forall a. Maybe a
Nothing

-- | Encoding to text just takes the text representation without further
-- processing.
instance ContextEncodable Text where
    encode :: GVal m -> VarName
encode = GVal m -> VarName
forall (m :: * -> *). GVal m -> VarName
asText
    newlines :: Maybe (Newlines VarName)
newlines = Newlines VarName -> Maybe (Newlines VarName)
forall a. a -> Maybe a
Just Newlines VarName
textNewlines

-- | Encoding to Html is implemented as returning the 'asHtml' representation.
instance ContextEncodable Html where
    encode :: GVal m -> Html
encode = GVal m -> Html
forall s. ToHtml s => s -> Html
toHtml
    newlines :: Maybe (Newlines Html)
newlines = Newlines Html -> Maybe (Newlines Html)
forall a. a -> Maybe a
Just Newlines Html
htmlNewlines

-- | Create an execution context for runGingerT.
-- Takes a lookup function, which returns ginger values into the carrier monad
-- based on a lookup key, and a writer function (outputting HTML by whatever
-- means the carrier monad provides, e.g. @putStr@ for @IO@, or @tell@ for
-- @Writer@s).
makeContextM' :: Monad m
             => (VarName -> Run p m h (GVal (Run p m h)))
             -> (h -> m ())
             -> (GVal (Run p m h) -> h)
             -> Maybe (Newlines h)
             -> GingerContext p m h
makeContextM' :: (VarName -> Run p m h (GVal (Run p m h)))
-> (h -> m ())
-> (GVal (Run p m h) -> h)
-> Maybe (Newlines h)
-> GingerContext p m h
makeContextM' VarName -> Run p m h (GVal (Run p m h))
lookupFn h -> m ()
writeFn GVal (Run p m h) -> h
encodeFn Maybe (Newlines h)
newlines =
  (VarName -> Run p m h (GVal (Run p m h)))
-> (h -> m ())
-> (RuntimeError p -> m ())
-> (GVal (Run p m h) -> h)
-> Maybe (Newlines h)
-> GingerContext p m h
forall (m :: * -> *) p h.
Monad m =>
(VarName -> Run p m h (GVal (Run p m h)))
-> (h -> m ())
-> (RuntimeError p -> m ())
-> (GVal (Run p m h) -> h)
-> Maybe (Newlines h)
-> GingerContext p m h
makeContextExM' VarName -> Run p m h (GVal (Run p m h))
lookupFn h -> m ()
writeFn (m () -> RuntimeError p -> m ()
forall a b. a -> b -> a
Prelude.const (m () -> RuntimeError p -> m ()) -> m () -> RuntimeError p -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) GVal (Run p m h) -> h
encodeFn Maybe (Newlines h)
newlines

makeContextExM' :: Monad m
             => (VarName -> Run p m h (GVal (Run p m h)))
             -> (h -> m ())
             -> (RuntimeError p -> m ())
             -> (GVal (Run p m h) -> h)
             -> Maybe (Newlines h)
             -> GingerContext p m h
makeContextExM' :: (VarName -> Run p m h (GVal (Run p m h)))
-> (h -> m ())
-> (RuntimeError p -> m ())
-> (GVal (Run p m h) -> h)
-> Maybe (Newlines h)
-> GingerContext p m h
makeContextExM' VarName -> Run p m h (GVal (Run p m h))
lookupFn h -> m ()
writeFn RuntimeError p -> m ()
warnFn GVal (Run p m h) -> h
encodeFn Maybe (Newlines h)
newlines =
    GingerContext :: forall p (m :: * -> *) h.
(VarName -> Run p m h (GVal (Run p m h)))
-> (h -> Run p m h ())
-> (RuntimeError p -> Run p m h ())
-> (GVal (Run p m h) -> h)
-> Maybe (Newlines h)
-> GingerContext p m h
GingerContext
        { contextLookup :: VarName -> Run p m h (GVal (Run p m h))
contextLookup = VarName -> Run p m h (GVal (Run p m h))
lookupFn
        , contextWrite :: h -> Run p m h ()
contextWrite = (h -> m ()) -> h -> Run p m h ()
forall (m :: * -> *) a b p h.
Monad m =>
(a -> m b) -> a -> Run p m h b
liftRun2 h -> m ()
writeFn
        , contextWarn :: RuntimeError p -> Run p m h ()
contextWarn = (RuntimeError p -> m ()) -> RuntimeError p -> Run p m h ()
forall (m :: * -> *) a b p h.
Monad m =>
(a -> m b) -> a -> Run p m h b
liftRun2 RuntimeError p -> m ()
warnFn
        , contextEncode :: GVal (Run p m h) -> h
contextEncode = GVal (Run p m h) -> h
encodeFn
        , contextNewlines :: Maybe (Newlines h)
contextNewlines = Maybe (Newlines h)
newlines
        }

liftLookup :: (Monad m, ToGVal (Run p m h) v) => (VarName -> m v) -> VarName -> Run p m h (GVal (Run p m h))
liftLookup :: (VarName -> m v) -> VarName -> Run p m h (GVal (Run p m h))
liftLookup VarName -> m v
f VarName
k = do
    v
v <- m v -> Run p m h v
forall (m :: * -> *) a p h. Monad m => m a -> Run p m h a
liftRun (m v -> Run p m h v) -> m v -> Run p m h v
forall a b. (a -> b) -> a -> b
$ VarName -> m v
f VarName
k
    GVal (Run p m h) -> Run p m h (GVal (Run p m h))
forall (m :: * -> *) a. Monad m => a -> m a
return (GVal (Run p m h) -> Run p m h (GVal (Run p m h)))
-> (v -> GVal (Run p m h)) -> v -> Run p m h (GVal (Run p m h))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. v -> GVal (Run p m h)
forall (m :: * -> *) a. ToGVal m a => a -> GVal m
toGVal (v -> Run p m h (GVal (Run p m h)))
-> v -> Run p m h (GVal (Run p m h))
forall a b. (a -> b) -> a -> b
$ v
v

-- | Create an execution context for runGinger.
-- The argument is a lookup function that maps top-level context keys to ginger
-- values. 'makeContext' is a specialized version of 'makeContextM', targeting
-- the 'Writer' 'Html' monad (which is what is used for the non-monadic
-- template interpreter 'runGinger').
--
-- The type of the lookup function may look intimidating, but in most cases,
-- marshalling values from Haskell to Ginger is a matter of calling 'toGVal'
-- on them, so the 'GVal (Run (Writer Html))' part can usually be ignored.
-- See the 'Text.Ginger.GVal' module for details.
makeContext' :: Monoid h
            => (VarName -> GVal (Run p (Writer h) h))
            -> (GVal (Run p (Writer h) h) -> h)
            -> Maybe (Newlines h)
            -> GingerContext p (Writer h) h
makeContext' :: (VarName -> GVal (Run p (Writer h) h))
-> (GVal (Run p (Writer h) h) -> h)
-> Maybe (Newlines h)
-> GingerContext p (Writer h) h
makeContext' VarName -> GVal (Run p (Writer h) h)
lookupFn =
    (VarName -> Run p (Writer h) h (GVal (Run p (Writer h) h)))
-> (h -> Writer h ())
-> (GVal (Run p (Writer h) h) -> h)
-> Maybe (Newlines h)
-> GingerContext p (Writer h) h
forall (m :: * -> *) p h.
Monad m =>
(VarName -> Run p m h (GVal (Run p m h)))
-> (h -> m ())
-> (GVal (Run p m h) -> h)
-> Maybe (Newlines h)
-> GingerContext p m h
makeContextM'
        (GVal (Run p (Writer h) h)
-> Run p (Writer h) h (GVal (Run p (Writer h) h))
forall (m :: * -> *) a. Monad m => a -> m a
return (GVal (Run p (Writer h) h)
 -> Run p (Writer h) h (GVal (Run p (Writer h) h)))
-> (VarName -> GVal (Run p (Writer h) h))
-> VarName
-> Run p (Writer h) h (GVal (Run p (Writer h) h))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName -> GVal (Run p (Writer h) h)
lookupFn)
        h -> Writer h ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell

{-#DEPRECATED makeContext "Compatibility alias for makeContextHtml" #-}
makeContext :: (VarName -> GVal (Run p (Writer Html) Html))
            -> GingerContext p (Writer Html) Html
makeContext :: (VarName -> GVal (Run p (Writer Html) Html))
-> GingerContext p (Writer Html) Html
makeContext = (VarName -> GVal (Run p (Writer Html) Html))
-> GingerContext p (Writer Html) Html
forall p.
(VarName -> GVal (Run p (Writer Html) Html))
-> GingerContext p (Writer Html) Html
makeContextHtml

{-#DEPRECATED makeContextM "Compatibility alias for makeContextHtmlM" #-}
makeContextM :: Monad m
             => (VarName -> Run p m Html (GVal (Run p m Html)))
             -> (Html -> m ())
             -> GingerContext p m Html
makeContextM :: (VarName -> Run p m Html (GVal (Run p m Html)))
-> (Html -> m ()) -> GingerContext p m Html
makeContextM = (VarName -> Run p m Html (GVal (Run p m Html)))
-> (Html -> m ()) -> GingerContext p m Html
forall (m :: * -> *) p.
Monad m =>
(VarName -> Run p m Html (GVal (Run p m Html)))
-> (Html -> m ()) -> GingerContext p m Html
makeContextHtmlM

makeContextHtml :: (VarName -> GVal (Run p (Writer Html) Html))
                -> GingerContext p (Writer Html) Html
makeContextHtml :: (VarName -> GVal (Run p (Writer Html) Html))
-> GingerContext p (Writer Html) Html
makeContextHtml VarName -> GVal (Run p (Writer Html) Html)
l = (VarName -> GVal (Run p (Writer Html) Html))
-> (GVal (Run p (Writer Html) Html) -> Html)
-> Maybe (Newlines Html)
-> GingerContext p (Writer Html) Html
forall h p.
Monoid h =>
(VarName -> GVal (Run p (Writer h) h))
-> (GVal (Run p (Writer h) h) -> h)
-> Maybe (Newlines h)
-> GingerContext p (Writer h) h
makeContext' VarName -> GVal (Run p (Writer Html) Html)
l GVal (Run p (Writer Html) Html) -> Html
forall s. ToHtml s => s -> Html
toHtml (Newlines Html -> Maybe (Newlines Html)
forall a. a -> Maybe a
Just Newlines Html
htmlNewlines)

makeContextHtmlM :: Monad m
                 => (VarName -> Run p m Html (GVal (Run p m Html)))
                 -> (Html -> m ())
                 -> GingerContext p m Html
makeContextHtmlM :: (VarName -> Run p m Html (GVal (Run p m Html)))
-> (Html -> m ()) -> GingerContext p m Html
makeContextHtmlM VarName -> Run p m Html (GVal (Run p m Html))
l Html -> m ()
w = (VarName -> Run p m Html (GVal (Run p m Html)))
-> (Html -> m ())
-> (GVal (Run p m Html) -> Html)
-> Maybe (Newlines Html)
-> GingerContext p m Html
forall (m :: * -> *) p h.
Monad m =>
(VarName -> Run p m h (GVal (Run p m h)))
-> (h -> m ())
-> (GVal (Run p m h) -> h)
-> Maybe (Newlines h)
-> GingerContext p m h
makeContextM' VarName -> Run p m Html (GVal (Run p m Html))
l Html -> m ()
w GVal (Run p m Html) -> Html
forall s. ToHtml s => s -> Html
toHtml (Newlines Html -> Maybe (Newlines Html)
forall a. a -> Maybe a
Just Newlines Html
htmlNewlines)

makeContextHtmlExM :: Monad m
                 => (VarName -> Run p m Html (GVal (Run p m Html)))
                 -> (Html -> m ())
                 -> (RuntimeError p -> m ())
                 -> GingerContext p m Html
makeContextHtmlExM :: (VarName -> Run p m Html (GVal (Run p m Html)))
-> (Html -> m ())
-> (RuntimeError p -> m ())
-> GingerContext p m Html
makeContextHtmlExM VarName -> Run p m Html (GVal (Run p m Html))
l Html -> m ()
w RuntimeError p -> m ()
warn = (VarName -> Run p m Html (GVal (Run p m Html)))
-> (Html -> m ())
-> (RuntimeError p -> m ())
-> (GVal (Run p m Html) -> Html)
-> Maybe (Newlines Html)
-> GingerContext p m Html
forall (m :: * -> *) p h.
Monad m =>
(VarName -> Run p m h (GVal (Run p m h)))
-> (h -> m ())
-> (RuntimeError p -> m ())
-> (GVal (Run p m h) -> h)
-> Maybe (Newlines h)
-> GingerContext p m h
makeContextExM' VarName -> Run p m Html (GVal (Run p m Html))
l Html -> m ()
w RuntimeError p -> m ()
warn GVal (Run p m Html) -> Html
forall s. ToHtml s => s -> Html
toHtml (Newlines Html -> Maybe (Newlines Html)
forall a. a -> Maybe a
Just Newlines Html
htmlNewlines)

makeContextText :: (VarName -> GVal (Run p (Writer Text) Text))
                -> GingerContext p (Writer Text) Text
makeContextText :: (VarName -> GVal (Run p (Writer VarName) VarName))
-> GingerContext p (Writer VarName) VarName
makeContextText VarName -> GVal (Run p (Writer VarName) VarName)
l = (VarName -> GVal (Run p (Writer VarName) VarName))
-> (GVal (Run p (Writer VarName) VarName) -> VarName)
-> Maybe (Newlines VarName)
-> GingerContext p (Writer VarName) VarName
forall h p.
Monoid h =>
(VarName -> GVal (Run p (Writer h) h))
-> (GVal (Run p (Writer h) h) -> h)
-> Maybe (Newlines h)
-> GingerContext p (Writer h) h
makeContext' VarName -> GVal (Run p (Writer VarName) VarName)
l GVal (Run p (Writer VarName) VarName) -> VarName
forall (m :: * -> *). GVal m -> VarName
asText (Newlines VarName -> Maybe (Newlines VarName)
forall a. a -> Maybe a
Just Newlines VarName
textNewlines)

makeContextTextM :: Monad m
                 => (VarName -> Run p m Text (GVal (Run p m Text)))
                 -> (Text -> m ())
                 -> GingerContext p m Text
makeContextTextM :: (VarName -> Run p m VarName (GVal (Run p m VarName)))
-> (VarName -> m ()) -> GingerContext p m VarName
makeContextTextM VarName -> Run p m VarName (GVal (Run p m VarName))
l VarName -> m ()
w = (VarName -> Run p m VarName (GVal (Run p m VarName)))
-> (VarName -> m ())
-> (GVal (Run p m VarName) -> VarName)
-> Maybe (Newlines VarName)
-> GingerContext p m VarName
forall (m :: * -> *) p h.
Monad m =>
(VarName -> Run p m h (GVal (Run p m h)))
-> (h -> m ())
-> (GVal (Run p m h) -> h)
-> Maybe (Newlines h)
-> GingerContext p m h
makeContextM' VarName -> Run p m VarName (GVal (Run p m VarName))
l VarName -> m ()
w GVal (Run p m VarName) -> VarName
forall (m :: * -> *). GVal m -> VarName
asText (Newlines VarName -> Maybe (Newlines VarName)
forall a. a -> Maybe a
Just Newlines VarName
textNewlines)

makeContextTextExM :: Monad m
                 => (VarName -> Run p m Text (GVal (Run p m Text)))
                 -> (Text -> m ())
                 -> (RuntimeError p -> m ())
                 -> GingerContext p m Text
makeContextTextExM :: (VarName -> Run p m VarName (GVal (Run p m VarName)))
-> (VarName -> m ())
-> (RuntimeError p -> m ())
-> GingerContext p m VarName
makeContextTextExM VarName -> Run p m VarName (GVal (Run p m VarName))
l VarName -> m ()
w RuntimeError p -> m ()
warn = (VarName -> Run p m VarName (GVal (Run p m VarName)))
-> (VarName -> m ())
-> (RuntimeError p -> m ())
-> (GVal (Run p m VarName) -> VarName)
-> Maybe (Newlines VarName)
-> GingerContext p m VarName
forall (m :: * -> *) p h.
Monad m =>
(VarName -> Run p m h (GVal (Run p m h)))
-> (h -> m ())
-> (RuntimeError p -> m ())
-> (GVal (Run p m h) -> h)
-> Maybe (Newlines h)
-> GingerContext p m h
makeContextExM' VarName -> Run p m VarName (GVal (Run p m VarName))
l VarName -> m ()
w RuntimeError p -> m ()
warn GVal (Run p m VarName) -> VarName
forall (m :: * -> *). GVal m -> VarName
asText (Newlines VarName -> Maybe (Newlines VarName)
forall a. a -> Maybe a
Just Newlines VarName
textNewlines)

-- | A 'Newlines' determines the rules by which a 'h' value can be
-- split into lines, how a list of lines can be joined into a single
-- value, and how to remove leading whitespace.
data Newlines h =
    Newlines
        { Newlines h -> h -> [h]
splitLines :: h -> [h]
        , Newlines h -> [h] -> h
joinLines :: [h] -> h
        , Newlines h -> h -> h
stripIndent :: h -> h
        , Newlines h -> h -> Bool
endsWithNewline :: h -> Bool
        }

-- | Hoist a 'Newlines' onto a different output type.
-- You don't normally need to use this directly; see 'hoistRun' and/or
-- 'hoistContext'.
hoistNewlines :: (h -> t) -> (t -> h) -> Newlines h -> Newlines t
hoistNewlines :: (h -> t) -> (t -> h) -> Newlines h -> Newlines t
hoistNewlines h -> t
fwd t -> h
rev Newlines h
n =
    Newlines :: forall h.
(h -> [h]) -> ([h] -> h) -> (h -> h) -> (h -> Bool) -> Newlines h
Newlines
        { splitLines :: t -> [t]
splitLines = (h -> t) -> [h] -> [t]
forall a b. (a -> b) -> [a] -> [b]
List.map h -> t
fwd ([h] -> [t]) -> (t -> [h]) -> t -> [t]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Newlines h -> h -> [h]
forall h. Newlines h -> h -> [h]
splitLines Newlines h
n (h -> [h]) -> (t -> h) -> t -> [h]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> h
rev
        , joinLines :: [t] -> t
joinLines = h -> t
fwd (h -> t) -> ([t] -> h) -> [t] -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Newlines h -> [h] -> h
forall h. Newlines h -> [h] -> h
joinLines Newlines h
n ([h] -> h) -> ([t] -> [h]) -> [t] -> h
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> h) -> [t] -> [h]
forall a b. (a -> b) -> [a] -> [b]
List.map t -> h
rev
        , stripIndent :: t -> t
stripIndent = h -> t
fwd (h -> t) -> (t -> h) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Newlines h -> h -> h
forall h. Newlines h -> h -> h
stripIndent Newlines h
n (h -> h) -> (t -> h) -> t -> h
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> h
rev
        , endsWithNewline :: t -> Bool
endsWithNewline = Newlines h -> h -> Bool
forall h. Newlines h -> h -> Bool
endsWithNewline Newlines h
n (h -> Bool) -> (t -> h) -> t -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> h
rev
        }

textNewlines :: Newlines Text
textNewlines :: Newlines VarName
textNewlines =
    Newlines :: forall h.
(h -> [h]) -> ([h] -> h) -> (h -> h) -> (h -> Bool) -> Newlines h
Newlines
        { splitLines :: VarName -> [VarName]
splitLines = [VarName] -> [VarName]
reNewline ([VarName] -> [VarName])
-> (VarName -> [VarName]) -> VarName -> [VarName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName -> VarName -> [VarName]
Text.splitOn VarName
"\n"
        , joinLines :: [VarName] -> VarName
joinLines = [VarName] -> VarName
forall a. Monoid a => [a] -> a
mconcat
        , stripIndent :: VarName -> VarName
stripIndent = VarName -> VarName
Text.stripStart
        , endsWithNewline :: VarName -> Bool
endsWithNewline = (VarName
"\n" VarName -> VarName -> Bool
`Text.isSuffixOf`)
        }

htmlNewlines :: Newlines Html
htmlNewlines :: Newlines Html
htmlNewlines =
    Newlines :: forall h.
(h -> [h]) -> ([h] -> h) -> (h -> h) -> (h -> Bool) -> Newlines h
Newlines
        { splitLines :: Html -> [Html]
splitLines = (VarName -> Html) -> [VarName] -> [Html]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap VarName -> Html
unsafeRawHtml ([VarName] -> [Html]) -> (Html -> [VarName]) -> Html -> [Html]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Newlines VarName -> VarName -> [VarName]
forall h. Newlines h -> h -> [h]
splitLines Newlines VarName
textNewlines (VarName -> [VarName]) -> (Html -> VarName) -> Html -> [VarName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> VarName
htmlSource
        , joinLines :: [Html] -> Html
joinLines = VarName -> Html
unsafeRawHtml (VarName -> Html) -> ([Html] -> VarName) -> [Html] -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Newlines VarName -> [VarName] -> VarName
forall h. Newlines h -> [h] -> h
joinLines Newlines VarName
textNewlines ([VarName] -> VarName)
-> ([Html] -> [VarName]) -> [Html] -> VarName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Html -> VarName) -> [Html] -> [VarName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Html -> VarName
htmlSource
        , stripIndent :: Html -> Html
stripIndent = VarName -> Html
unsafeRawHtml (VarName -> Html) -> (Html -> VarName) -> Html -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Newlines VarName -> VarName -> VarName
forall h. Newlines h -> h -> h
stripIndent Newlines VarName
textNewlines (VarName -> VarName) -> (Html -> VarName) -> Html -> VarName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> VarName
htmlSource
        , endsWithNewline :: Html -> Bool
endsWithNewline = Newlines VarName -> VarName -> Bool
forall h. Newlines h -> h -> Bool
endsWithNewline Newlines VarName
textNewlines (VarName -> Bool) -> (Html -> VarName) -> Html -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> VarName
htmlSource
        }

-- | Helper; reinstates newlines after splitting a 'Text' into lines.
reNewline :: [Text] -> [Text]
reNewline :: [VarName] -> [VarName]
reNewline [] = []
reNewline (VarName
"":[]) = []
reNewline (VarName
x:[]) = [VarName
x]
reNewline (VarName
x:VarName
"":[]) = [VarName
x VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> VarName
"\n"]
reNewline (VarName
x:[VarName]
xs) = (VarName
x VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> VarName
"\n") VarName -> [VarName] -> [VarName]
forall a. a -> [a] -> [a]
: [VarName] -> [VarName]
reNewline [VarName]
xs

data RunState p m h
    = RunState
        { RunState p m h -> HashMap VarName (GVal (Run p m h))
rsScope :: HashMap VarName (GVal (Run p m h))
        , RunState p m h -> h
rsCapture :: h
        , RunState p m h -> Template p
rsCurrentTemplate :: Template p -- the template we are currently running
        , RunState p m h -> Maybe VarName
rsCurrentBlockName :: Maybe Text -- the name of the innermost block we're currently in
        , RunState p m h -> Maybe [h]
rsIndentation :: Maybe [h] -- current indentation level, if any
        , RunState p m h -> Bool
rsAtLineStart :: Bool -- is the next output position the first column
        , RunState p m h -> p
rsCurrentSourcePos :: p
        }

-- | Hoist a 'RunState' onto a different output type.
-- You don't normally need to use this directly; see 'hoistRun' and/or
-- 'hoistContext'.
hoistRunState :: Monad m => (h -> t) -> (t -> h) -> RunState p m h -> RunState p m t
hoistRunState :: (h -> t) -> (t -> h) -> RunState p m h -> RunState p m t
hoistRunState h -> t
fwd t -> h
rev RunState p m h
rs =
    RunState :: forall p (m :: * -> *) h.
HashMap VarName (GVal (Run p m h))
-> h
-> Template p
-> Maybe VarName
-> Maybe [h]
-> Bool
-> p
-> RunState p m h
RunState
        { rsScope :: HashMap VarName (GVal (Run p m t))
rsScope = (forall a. Run p m h a -> Run p m t a)
-> (forall a. Run p m t a -> Run p m h a)
-> GVal (Run p m h)
-> GVal (Run p m t)
forall (m :: * -> *) (n :: * -> *).
(Functor m, Functor n) =>
(forall a. m a -> n a)
-> (forall a. n a -> m a) -> GVal m -> GVal n
marshalGValEx ((h -> t) -> (t -> h) -> Run p m h a -> Run p m t a
forall (m :: * -> *) h t p a.
Monad m =>
(h -> t) -> (t -> h) -> Run p m h a -> Run p m t a
hoistRun h -> t
fwd t -> h
rev) ((t -> h) -> (h -> t) -> Run p m t a -> Run p m h a
forall (m :: * -> *) h t p a.
Monad m =>
(h -> t) -> (t -> h) -> Run p m h a -> Run p m t a
hoistRun t -> h
rev h -> t
fwd) (GVal (Run p m h) -> GVal (Run p m t))
-> HashMap VarName (GVal (Run p m h))
-> HashMap VarName (GVal (Run p m t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunState p m h -> HashMap VarName (GVal (Run p m h))
forall p (m :: * -> *) h.
RunState p m h -> HashMap VarName (GVal (Run p m h))
rsScope RunState p m h
rs
        , rsCapture :: t
rsCapture = h -> t
fwd (h -> t) -> h -> t
forall a b. (a -> b) -> a -> b
$ RunState p m h -> h
forall p (m :: * -> *) h. RunState p m h -> h
rsCapture RunState p m h
rs
        , rsCurrentTemplate :: Template p
rsCurrentTemplate = RunState p m h -> Template p
forall p (m :: * -> *) h. RunState p m h -> Template p
rsCurrentTemplate RunState p m h
rs
        , rsCurrentBlockName :: Maybe VarName
rsCurrentBlockName = RunState p m h -> Maybe VarName
forall p (m :: * -> *) h. RunState p m h -> Maybe VarName
rsCurrentBlockName RunState p m h
rs
        , rsIndentation :: Maybe [t]
rsIndentation = (h -> t) -> [h] -> [t]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap h -> t
fwd ([h] -> [t]) -> Maybe [h] -> Maybe [t]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RunState p m h -> Maybe [h]
forall p (m :: * -> *) h. RunState p m h -> Maybe [h]
rsIndentation RunState p m h
rs
        , rsAtLineStart :: Bool
rsAtLineStart = RunState p m h -> Bool
forall p (m :: * -> *) h. RunState p m h -> Bool
rsAtLineStart RunState p m h
rs
        , rsCurrentSourcePos :: p
rsCurrentSourcePos = RunState p m h -> p
forall p (m :: * -> *) h. RunState p m h -> p
rsCurrentSourcePos RunState p m h
rs
        }

data RuntimeError p = RuntimeError Text -- ^ Generic runtime error
                    | UndefinedBlockError Text -- ^ Tried to use a block that isn't defined
                    -- | Invalid arguments to function (function name, explanation)
                    | ArgumentsError (Maybe Text) Text
                    -- | Wrong type, expected one of...
                    | TypeError [Text] (Maybe Text)
                    -- | Invalid index
                    | IndexError Text
                    | EvalParseError ParserError
                    | NotAFunctionError
                    | RuntimeErrorAt p (RuntimeError p)
        deriving (Int -> RuntimeError p -> ShowS
[RuntimeError p] -> ShowS
RuntimeError p -> String
(Int -> RuntimeError p -> ShowS)
-> (RuntimeError p -> String)
-> ([RuntimeError p] -> ShowS)
-> Show (RuntimeError p)
forall p. Show p => Int -> RuntimeError p -> ShowS
forall p. Show p => [RuntimeError p] -> ShowS
forall p. Show p => RuntimeError p -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RuntimeError p] -> ShowS
$cshowList :: forall p. Show p => [RuntimeError p] -> ShowS
show :: RuntimeError p -> String
$cshow :: forall p. Show p => RuntimeError p -> String
showsPrec :: Int -> RuntimeError p -> ShowS
$cshowsPrec :: forall p. Show p => Int -> RuntimeError p -> ShowS
Show)

instance Default (RuntimeError p) where
    def :: RuntimeError p
def = VarName -> RuntimeError p
forall p. VarName -> RuntimeError p
RuntimeError VarName
""

instance ToGVal m p => ToGVal m (RuntimeError p) where
    toGVal :: RuntimeError p -> GVal m
toGVal = RuntimeError p -> GVal m
forall (m :: * -> *) p. ToGVal m p => RuntimeError p -> GVal m
runtimeErrorToGVal

runtimeErrorWhat :: RuntimeError p -> Text
runtimeErrorWhat :: RuntimeError p -> VarName
runtimeErrorWhat (ArgumentsError Maybe VarName
funcName VarName
explanation) = VarName
"ArgumentsError"
runtimeErrorWhat (EvalParseError ParserError
e) = VarName
"EvalParseError"
runtimeErrorWhat (RuntimeError VarName
msg) = VarName
"RuntimeError"
runtimeErrorWhat (UndefinedBlockError VarName
blockName) = VarName
"UndefinedBlockError"
runtimeErrorWhat RuntimeError p
NotAFunctionError = VarName
"NotAFunctionError"
runtimeErrorWhat (IndexError VarName
_) = VarName
"IndexError"
runtimeErrorWhat (TypeError [VarName]
_ Maybe VarName
_) = VarName
"TypeError"
runtimeErrorWhat (RuntimeErrorAt p
_ RuntimeError p
e) = RuntimeError p -> VarName
forall p. RuntimeError p -> VarName
runtimeErrorWhat RuntimeError p
e

runtimeErrorMessage :: RuntimeError p -> Text
runtimeErrorMessage :: RuntimeError p -> VarName
runtimeErrorMessage (ArgumentsError Maybe VarName
Nothing VarName
explanation) =
    VarName
"invalid arguments: " VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> VarName
explanation
runtimeErrorMessage (ArgumentsError (Just VarName
funcName) VarName
explanation) =
    VarName
"invalid arguments to function '" VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> VarName
funcName VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> VarName
"': " VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> VarName
explanation
runtimeErrorMessage (TypeError [VarName]
expected Maybe VarName
actual) =
    VarName
"wrong type"
    VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> case [VarName]
expected of
        [] -> VarName
""
        [VarName
x] -> VarName
", expected " VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> VarName
x
        [VarName]
xs -> VarName
", expected " VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> ([VarName] -> VarName
forall a. Monoid a => [a] -> a
mconcat ([VarName] -> VarName)
-> ([VarName] -> [VarName]) -> [VarName] -> VarName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName -> [VarName] -> [VarName]
forall a. a -> [a] -> [a]
List.intersperse VarName
" or " ([VarName] -> VarName) -> [VarName] -> VarName
forall a b. (a -> b) -> a -> b
$ [VarName]
xs)
    VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> case Maybe VarName
actual of
        Maybe VarName
Nothing -> VarName
""
        Just VarName
x -> VarName
", found " VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> VarName
x
runtimeErrorMessage (IndexError VarName
i) =
    VarName
"invalid index " VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> VarName
i
runtimeErrorMessage (EvalParseError ParserError
e) =
    VarName
"parser error in eval()-ed code: " VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> String -> VarName
Text.pack (ParserError -> String
peErrorMessage ParserError
e)
runtimeErrorMessage (RuntimeError VarName
msg) =
    VarName
msg
runtimeErrorMessage (UndefinedBlockError VarName
blockName) =
    VarName
"undefined block: '" VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> VarName
blockName VarName -> VarName -> VarName
forall a. Semigroup a => a -> a -> a
<> VarName
"'"
runtimeErrorMessage RuntimeError p
NotAFunctionError =
    VarName
"attempted to call something that is not a function"
runtimeErrorMessage (RuntimeErrorAt p
_ RuntimeError p
e) =
    RuntimeError p -> VarName
forall p. RuntimeError p -> VarName
runtimeErrorMessage RuntimeError p
e

runtimeErrorWhere :: RuntimeError p -> [p]
runtimeErrorWhere :: RuntimeError p -> [p]
runtimeErrorWhere (RuntimeErrorAt p
p RuntimeError p
e) = p
pp -> [p] -> [p]
forall a. a -> [a] -> [a]
:RuntimeError p -> [p]
forall p. RuntimeError p -> [p]
runtimeErrorWhere RuntimeError p
e
runtimeErrorWhere RuntimeError p
_ = []

runtimeErrorToGVal :: forall m p. ToGVal m p => RuntimeError p -> GVal m
runtimeErrorToGVal :: RuntimeError p -> GVal m
runtimeErrorToGVal RuntimeError p
e =
    let ([p]
callStack, [(VarName, GVal m)]
props) = RuntimeError p -> ([p], [(VarName, GVal m)])
forall p (m :: * -> *).
RuntimeError p -> ([p], [(VarName, GVal m)])
runtimeErrorToGValRaw RuntimeError p
e
        props' :: [Pair m]
props' = ((VarName
"callStack" :: Text) VarName -> [p] -> Pair m
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> [p]
callStack)Pair m -> [Pair m] -> [Pair m]
forall a. a -> [a] -> [a]
:[Pair m]
forall (m :: * -> *). [(VarName, GVal m)]
props
    in ([Pair m] -> GVal m
forall (m :: * -> *). [Pair m] -> GVal m
dict [Pair m]
props') { asText :: VarName
asText = RuntimeError p -> VarName
forall p. RuntimeError p -> VarName
runtimeErrorMessage RuntimeError p
e }

runtimeErrorToGValRaw :: RuntimeError p -> ([p], [(Text, GVal m)])
runtimeErrorToGValRaw :: RuntimeError p -> ([p], [(VarName, GVal m)])
runtimeErrorToGValRaw (RuntimeError VarName
msg) =
    ( []
    , VarName -> [(VarName, GVal m)] -> [(VarName, GVal m)]
forall (m :: * -> *).
VarName -> [(VarName, GVal m)] -> [(VarName, GVal m)]
rteGVal VarName
"RuntimeError" []
    )
runtimeErrorToGValRaw (UndefinedBlockError VarName
blockName) =
    ( []
    , VarName -> [(VarName, GVal m)] -> [(VarName, GVal m)]
forall (m :: * -> *).
VarName -> [(VarName, GVal m)] -> [(VarName, GVal m)]
rteGVal VarName
"UndefinedBlockError"
        [ VarName
"block" VarName -> VarName -> (VarName, GVal m)
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> VarName
blockName
        ]
    )
runtimeErrorToGValRaw (ArgumentsError Maybe VarName
funcName VarName
explanation) =
    ( []
    , VarName -> [(VarName, GVal m)] -> [(VarName, GVal m)]
forall (m :: * -> *).
VarName -> [(VarName, GVal m)] -> [(VarName, GVal m)]
rteGVal VarName
"ArgumentsError"
        [ VarName
"explanation" VarName -> VarName -> (VarName, GVal m)
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> VarName
explanation
        , VarName
"function" VarName -> Maybe VarName -> (VarName, GVal m)
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> Maybe VarName
funcName
        ]
    )
runtimeErrorToGValRaw (TypeError [VarName]
expected Maybe VarName
Nothing) =
    ( []
    , VarName -> [(VarName, GVal m)] -> [(VarName, GVal m)]
forall (m :: * -> *).
VarName -> [(VarName, GVal m)] -> [(VarName, GVal m)]
rteGVal VarName
"ArgumentsError"
        [ VarName
"expected" VarName -> [VarName] -> (VarName, GVal m)
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> [VarName]
expected
        ]
    )
runtimeErrorToGValRaw (TypeError [VarName]
expected (Just VarName
actual)) =
    ( []
    , VarName -> [(VarName, GVal m)] -> [(VarName, GVal m)]
forall (m :: * -> *).
VarName -> [(VarName, GVal m)] -> [(VarName, GVal m)]
rteGVal VarName
"ArgumentsError"
        [ VarName
"expected" VarName -> [VarName] -> (VarName, GVal m)
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> [VarName]
expected
        , VarName
"actual" VarName -> VarName -> (VarName, GVal m)
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> VarName
actual
        ]
    )
runtimeErrorToGValRaw (EvalParseError ParserError
e) =
    ( []
    , VarName -> [(VarName, GVal m)] -> [(VarName, GVal m)]
forall (m :: * -> *).
VarName -> [(VarName, GVal m)] -> [(VarName, GVal m)]
rteGVal VarName
"EvalParseError"
        [ VarName
"errorMessage" VarName -> String -> (VarName, GVal m)
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> ParserError -> String
peErrorMessage ParserError
e
        -- , "sourcePosition" ~> peSourcePosition e
        ]
    )
runtimeErrorToGValRaw RuntimeError p
NotAFunctionError =
    ( []
    , VarName -> [(VarName, GVal m)] -> [(VarName, GVal m)]
forall (m :: * -> *).
VarName -> [(VarName, GVal m)] -> [(VarName, GVal m)]
rteGVal VarName
"NotAFunctionError"
        []
    )

runtimeErrorToGValRaw (RuntimeErrorAt p
p RuntimeError p
e) =
    let ([p]
callStack, [(VarName, GVal m)]
inner) = RuntimeError p -> ([p], [(VarName, GVal m)])
forall p (m :: * -> *).
RuntimeError p -> ([p], [(VarName, GVal m)])
runtimeErrorToGValRaw RuntimeError p
e
    in (p
pp -> [p] -> [p]
forall a. a -> [a] -> [a]
:[p]
callStack, [(VarName, GVal m)]
forall (m :: * -> *). [(VarName, GVal m)]
inner)

rteGVal :: Text -> [(Text, GVal m)] -> [(Text, GVal m)]
rteGVal :: VarName -> [(VarName, GVal m)] -> [(VarName, GVal m)]
rteGVal VarName
what [(VarName, GVal m)]
extra =
    ( [ VarName
"what" VarName -> VarName -> (VarName, GVal m)
forall (m :: * -> *) a. ToGVal m a => VarName -> a -> Pair m
~> VarName
what
      ]
      [(VarName, GVal m)] -> [(VarName, GVal m)] -> [(VarName, GVal m)]
forall a. [a] -> [a] -> [a]
++ [(VarName, GVal m)]
extra
    )

-- | Internal type alias for our template-runner monad stack.
type Run p m h = ExceptT (RuntimeError p) (StateT (RunState p m h) (ReaderT (GingerContext p m h) m))

-- | Lift a value from the host monad @m@ into the 'Run' monad.
liftRun :: Monad m => m a -> Run p m h a
liftRun :: m a -> Run p m h a
liftRun = StateT (RunState p m h) (ReaderT (GingerContext p m h) m) a
-> Run p m h a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (RunState p m h) (ReaderT (GingerContext p m h) m) a
 -> Run p m h a)
-> (m a
    -> StateT (RunState p m h) (ReaderT (GingerContext p m h) m) a)
-> m a
-> Run p m h a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT (GingerContext p m h) m a
-> StateT (RunState p m h) (ReaderT (GingerContext p m h) m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT (GingerContext p m h) m a
 -> StateT (RunState p m h) (ReaderT (GingerContext p m h) m) a)
-> (m a -> ReaderT (GingerContext p m h) m a)
-> m a
-> StateT (RunState p m h) (ReaderT (GingerContext p m h) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ReaderT (GingerContext p m h) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | Lift a function from the host monad @m@ into the 'Run' monad.
liftRun2 :: Monad m => (a -> m b) -> a -> Run p m h b
liftRun2 :: (a -> m b) -> a -> Run p m h b
liftRun2 a -> m b
f a
x = m b -> Run p m h b
forall (m :: * -> *) a p h. Monad m => m a -> Run p m h a
liftRun (m b -> Run p m h b) -> m b -> Run p m h b
forall a b. (a -> b) -> a -> b
$ a -> m b
f a
x

-- | Hoist a 'Run' action onto a different output type.
-- @hoistRun fwd rev action@ hoists the @action@ from @Run p m h a@ to
-- @Run p m t a@, applying @fwd@ and @rev@ to convert between the output
-- types.
hoistRun :: Monad m => (h -> t) -> (t -> h) -> Run p m h a -> Run p m t a
hoistRun :: (h -> t) -> (t -> h) -> Run p m h a -> Run p m t a
hoistRun h -> t
fwd t -> h
rev Run p m h a
action = do
    GingerContext p m t
contextT <- ExceptT
  (RuntimeError p)
  (StateT (RunState p m t) (ReaderT (GingerContext p m t) m))
  (GingerContext p m t)
forall r (m :: * -> *). MonadReader r m => m r
ask
    let contextH :: GingerContext p m h
contextH = (t -> h) -> (h -> t) -> GingerContext p m t -> GingerContext p m h
forall (m :: * -> *) h t p.
Monad m =>
(h -> t) -> (t -> h) -> GingerContext p m h -> GingerContext p m t
hoistContext t -> h
rev h -> t
fwd GingerContext p m t
contextT
    RunState p m t
stateT <- ExceptT
  (RuntimeError p)
  (StateT (RunState p m t) (ReaderT (GingerContext p m t) m))
  (RunState p m t)
forall s (m :: * -> *). MonadState s m => m s
get
    let stateH :: RunState p m h
stateH = (t -> h) -> (h -> t) -> RunState p m t -> RunState p m h
forall (m :: * -> *) h t p.
Monad m =>
(h -> t) -> (t -> h) -> RunState p m h -> RunState p m t
hoistRunState t -> h
rev h -> t
fwd RunState p m t
stateT
    (Either (RuntimeError p) a
x, RunState p m h
stateH') <- StateT
  (RunState p m t)
  (ReaderT (GingerContext p m t) m)
  (Either (RuntimeError p) a, RunState p m h)
-> ExceptT
     (RuntimeError p)
     (StateT (RunState p m t) (ReaderT (GingerContext p m t) m))
     (Either (RuntimeError p) a, RunState p m h)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT
   (RunState p m t)
   (ReaderT (GingerContext p m t) m)
   (Either (RuntimeError p) a, RunState p m h)
 -> ExceptT
      (RuntimeError p)
      (StateT (RunState p m t) (ReaderT (GingerContext p m t) m))
      (Either (RuntimeError p) a, RunState p m h))
-> (m (Either (RuntimeError p) a, RunState p m h)
    -> StateT
         (RunState p m t)
         (ReaderT (GingerContext p m t) m)
         (Either (RuntimeError p) a, RunState p m h))
-> m (Either (RuntimeError p) a, RunState p m h)
-> ExceptT
     (RuntimeError p)
     (StateT (RunState p m t) (ReaderT (GingerContext p m t) m))
     (Either (RuntimeError p) a, RunState p m h)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT
  (GingerContext p m t) m (Either (RuntimeError p) a, RunState p m h)
-> StateT
     (RunState p m t)
     (ReaderT (GingerContext p m t) m)
     (Either (RuntimeError p) a, RunState p m h)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT
   (GingerContext p m t) m (Either (RuntimeError p) a, RunState p m h)
 -> StateT
      (RunState p m t)
      (ReaderT (GingerContext p m t) m)
      (Either (RuntimeError p) a, RunState p m h))
-> (m (Either (RuntimeError p) a, RunState p m h)
    -> ReaderT
         (GingerContext p m t)
         m
         (Either (RuntimeError p) a, RunState p m h))
-> m (Either (RuntimeError p) a, RunState p m h)
-> StateT
     (RunState p m t)
     (ReaderT (GingerContext p m t) m)
     (Either (RuntimeError p) a, RunState p m h)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either (RuntimeError p) a, RunState p m h)
-> ReaderT
     (GingerContext p m t) m (Either (RuntimeError p) a, RunState p m h)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either (RuntimeError p) a, RunState p m h)
 -> ExceptT
      (RuntimeError p)
      (StateT (RunState p m t) (ReaderT (GingerContext p m t) m))
      (Either (RuntimeError p) a, RunState p m h))
-> m (Either (RuntimeError p) a, RunState p m h)
-> ExceptT
     (RuntimeError p)
     (StateT (RunState p m t) (ReaderT (GingerContext p m t) m))
     (Either (RuntimeError p) a, RunState p m h)
forall a b. (a -> b) -> a -> b
$ ReaderT
  (GingerContext p m h) m (Either (RuntimeError p) a, RunState p m h)
-> GingerContext p m h
-> m (Either (RuntimeError p) a, RunState p m h)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT
  (RunState p m h)
  (ReaderT (GingerContext p m h) m)
  (Either (RuntimeError p) a)
-> RunState p m h
-> ReaderT
     (GingerContext p m h) m (Either (RuntimeError p) a, RunState p m h)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (Run p m h a
-> StateT
     (RunState p m h)
     (ReaderT (GingerContext p m h) m)
     (Either (RuntimeError p) a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT Run p m h a
action) RunState p m h
stateH) GingerContext p m h
contextH
    let stateT' :: RunState p m t
stateT' = (h -> t) -> (t -> h) -> RunState p m h -> RunState p m t
forall (m :: * -> *) h t p.
Monad m =>
(h -> t) -> (t -> h) -> RunState p m h -> RunState p m t
hoistRunState h -> t
fwd t -> h
rev RunState p m h
stateH'
    RunState p m t
-> ExceptT
     (RuntimeError p)
     (StateT (RunState p m t) (ReaderT (GingerContext p m t) m))
     ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put RunState p m t
stateT'
    (RuntimeError p -> Run p m t a)
-> (a -> Run p m t a) -> Either (RuntimeError p) a -> Run p m t a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
Prelude.either RuntimeError p -> Run p m t a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError a -> Run p m t a
forall (m :: * -> *) a. Monad m => a -> m a
return Either (RuntimeError p) a
x

warn :: (Monad m) => RuntimeError p -> Run p m h ()
warn :: RuntimeError p -> Run p m h ()
warn RuntimeError p
err = do
    p
pos <- Run p m h p
forall (m :: * -> *) p h. Monad m => Run p m h p
getSourcePos
    RuntimeError p -> Run p m h ()
warnFn <- (GingerContext p m h -> RuntimeError p -> Run p m h ())
-> ExceptT
     (RuntimeError p)
     (StateT (RunState p m h) (ReaderT (GingerContext p m h) m))
     (RuntimeError p -> Run p m h ())
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks GingerContext p m h -> RuntimeError p -> Run p m h ()
forall p (m :: * -> *) h.
GingerContext p m h -> RuntimeError p -> Run p m h ()
contextWarn
    RuntimeError p -> Run p m h ()
warnFn (RuntimeError p -> Run p m h ()) -> RuntimeError p -> Run p m h ()
forall a b. (a -> b) -> a -> b
$ p -> RuntimeError p -> RuntimeError p
forall p. p -> RuntimeError p -> RuntimeError p
RuntimeErrorAt p
pos RuntimeError p
err

warnFromMaybe :: Monad m => RuntimeError p -> a -> Maybe a -> Run p m h a
warnFromMaybe :: RuntimeError p -> a -> Maybe a -> Run p m h a
warnFromMaybe RuntimeError p
err a
d Maybe a
Nothing = RuntimeError p -> Run p m h ()
forall (m :: * -> *) p h. Monad m => RuntimeError p -> Run p m h ()
warn RuntimeError p
err Run p m h () -> Run p m h a -> Run p m h a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Run p m h a
forall (m :: * -> *) a. Monad m => a -> m a
return a
d
warnFromMaybe RuntimeError p
_ a
d (Just a
x) = a -> Run p m h a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

setSourcePos :: Monad m
             => p
             -> Run p m h ()
setSourcePos :: p -> Run p m h ()
setSourcePos p
pos =
  (RunState p m h -> RunState p m h) -> Run p m h ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (\RunState p m h
s -> RunState p m h
s { rsCurrentSourcePos :: p
rsCurrentSourcePos = p
pos })

getSourcePos :: Monad m
             => Run p m h p
getSourcePos :: Run p m h p
getSourcePos = (RunState p m h -> p) -> Run p m h p
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets RunState p m h -> p
forall p (m :: * -> *) h. RunState p m h -> p
rsCurrentSourcePos

throwHere :: Monad m => RuntimeError p -> Run p m h a
throwHere :: RuntimeError p -> Run p m h a
throwHere RuntimeError p
err = do
    p
pos <- Run p m h p
forall (m :: * -> *) p h. Monad m => Run p m h p
getSourcePos
    RuntimeError p -> Run p m h a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RuntimeError p -> Run p m h a) -> RuntimeError p -> Run p m h a
forall a b. (a -> b) -> a -> b
$ p -> RuntimeError p -> RuntimeError p
forall p. p -> RuntimeError p -> RuntimeError p
RuntimeErrorAt p
pos RuntimeError p
err

-- | @withSourcePos pos action@ runs @action@ in a context where the
-- current source location is set to @pos@. The original source position is
-- restored when @action@ finishes.
withSourcePos :: Monad m
              => p
              -> Run p m h a
              -> Run p m h a
withSourcePos :: p -> Run p m h a -> Run p m h a
withSourcePos p
pos Run p m h a
a = do
  p
oldPos <- Run p m h p
forall (m :: * -> *) p h. Monad m => Run p m h p
getSourcePos
  Run p m h a -> (RuntimeError p -> Run p m h a) -> Run p m h a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError
    (p -> Run p m h ()
forall (m :: * -> *) p h. Monad m => p -> Run p m h ()
setSourcePos p
pos Run p m h () -> Run p m h a -> Run p m h a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Run p m h a
a Run p m h a -> Run p m h () -> Run p m h a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* p -> Run p m h ()
forall (m :: * -> *) p h. Monad m => p -> Run p m h ()
setSourcePos p
oldPos)
    (\RuntimeError p
err -> RuntimeError p -> Run p m h a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (RuntimeError p -> Run p m h a) -> RuntimeError p -> Run p m h a
forall a b. (a -> b) -> a -> b
$ p -> RuntimeError p -> RuntimeError p
forall p. p -> RuntimeError p -> RuntimeError p
RuntimeErrorAt p
oldPos RuntimeError p
err)