{-#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.Trans.Except (ExceptT (..), runExceptT)
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.Monoid (Monoid (..), (<>))
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
        { forall p (m :: * -> *) h.
GingerContext p m h -> Text -> Run p m h (GVal (Run p m h))
contextLookup :: VarName -> Run p m h (GVal (Run p m h))
        , forall p (m :: * -> *) h. GingerContext p m h -> h -> Run p m h ()
contextWrite :: h -> 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 ()
        , forall p (m :: * -> *) h.
GingerContext p m h -> GVal (Run p m h) -> h
contextEncode :: GVal (Run p m h) -> h
        , forall p (m :: * -> *) 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 :: forall (m :: * -> *) h t p.
Monad m =>
(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
        { contextLookup :: Text
-> Run
     p
     m
     t
     (GVal
        (ExceptT
           (RuntimeError p)
           (StateT (RunState p m t) (ReaderT (GingerContext p m t) m))))
contextLookup = \Text
varName ->
            forall (m :: * -> *) (n :: * -> *).
(Functor m, Functor n) =>
(forall a. m a -> n a)
-> (forall a. n a -> m a) -> GVal m -> GVal n
marshalGValEx
                (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)
                (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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                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 (forall p (m :: * -> *) h.
GingerContext p m h -> Text -> Run p m h (GVal (Run p m h))
contextLookup GingerContext p m h
c Text
varName)
        , contextWrite :: t -> Run p m t ()
contextWrite = \t
val ->
            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 (forall p (m :: * -> *) h. GingerContext p m h -> h -> Run p m h ()
contextWrite GingerContext p m h
c forall a b. (a -> b) -> a -> b
$ t -> h
rev t
val)
        , contextWarn :: RuntimeError p -> Run p m t ()
contextWarn = \RuntimeError p
str ->
            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 (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
  (ExceptT
     (RuntimeError p)
     (StateT (RunState p m t) (ReaderT (GingerContext p m t) m)))
-> t
contextEncode = \GVal
  (ExceptT
     (RuntimeError p)
     (StateT (RunState p m t) (ReaderT (GingerContext p m t) m)))
gval ->
            h -> t
fwd forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                forall p (m :: * -> *) h.
GingerContext p m h -> GVal (Run p m h) -> h
contextEncode GingerContext p m h
c forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                forall (m :: * -> *) (n :: * -> *).
(Functor m, Functor n) =>
(forall a. m a -> n a)
-> (forall a. n a -> m a) -> GVal m -> GVal n
marshalGValEx (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) (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) forall a b. (a -> b) -> a -> b
$
                GVal
  (ExceptT
     (RuntimeError p)
     (StateT (RunState p m t) (ReaderT (GingerContext p m t) m)))
gval
        , contextNewlines :: Maybe (Newlines t)
contextNewlines =
            forall h t. (h -> t) -> (t -> h) -> Newlines h -> Newlines t
hoistNewlines h -> t
fwd t -> h
rev forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall p (m :: * -> *) h.
GingerContext p m h -> GVal (Run p m h) -> Run p m h ()
contextWriteEncoded GingerContext p m h
context =
    forall p (m :: * -> *) h. GingerContext p m h -> h -> Run p m h ()
contextWrite GingerContext p m h
context forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (m :: * -> *) h p v.
(Monad m, ContextEncodable h, ToGVal (Run p m h) v) =>
(h -> m ()) -> v -> GingerContext p m h
easyContext h -> m ()
emit v
context =
    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 (forall a b. a -> b -> a
Prelude.const forall a b. (a -> b) -> a -> b
$ 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 :: 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 RuntimeError p -> m ()
warn v
context =
    forall (m :: * -> *) p h.
Monad m =>
(Text -> 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'
        (\Text
varName ->
            forall (m :: * -> *) a. Monad m => a -> m a
return
                (forall (m :: * -> *). GVal m -> GVal m -> GVal m -> GVal m
lookupLooseDef forall a. Default a => a
def
                    (forall (m :: * -> *) a. ToGVal m a => a -> GVal m
toGVal Text
varName)
                    (forall (m :: * -> *) a. ToGVal m a => a -> GVal m
toGVal v
context)))
        h -> m ()
emit
        RuntimeError p -> m ()
warn
        forall h (m :: * -> *). ContextEncodable h => GVal m -> h
encode
        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 = forall a. Maybe a
Nothing

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

-- | Encoding to Html is implemented as returning the 'asHtml' representation.
instance ContextEncodable Html where
    encode :: forall (m :: * -> *). GVal m -> Html
encode = forall s. ToHtml s => s -> Html
toHtml
    newlines :: Maybe (Newlines Html)
newlines = 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' :: forall (m :: * -> *) p h.
Monad m =>
(Text -> 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' Text -> Run p m h (GVal (Run p m h))
lookupFn h -> m ()
writeFn GVal (Run p m h) -> h
encodeFn Maybe (Newlines h)
newlines =
  forall (m :: * -> *) p h.
Monad m =>
(Text -> 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' Text -> Run p m h (GVal (Run p m h))
lookupFn h -> m ()
writeFn (forall a b. a -> b -> a
Prelude.const forall a b. (a -> b) -> a -> b
$ 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' :: forall (m :: * -> *) p h.
Monad m =>
(Text -> 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' Text -> 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
        { contextLookup :: Text -> Run p m h (GVal (Run p m h))
contextLookup = Text -> Run p m h (GVal (Run p m h))
lookupFn
        , contextWrite :: h -> Run p m h ()
contextWrite = 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 = 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 :: forall (m :: * -> *) p h v.
(Monad m, ToGVal (Run p m h) v) =>
(Text -> m v) -> Text -> Run p m h (GVal (Run p m h))
liftLookup Text -> m v
f Text
k = do
    v
v <- forall (m :: * -> *) a p h. Monad m => m a -> Run p m h a
liftRun forall a b. (a -> b) -> a -> b
$ Text -> m v
f Text
k
    forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. ToGVal m a => a -> GVal m
toGVal 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' :: forall h p.
Monoid h =>
(Text -> GVal (Run p (Writer h) h))
-> (GVal (Run p (Writer h) h) -> h)
-> Maybe (Newlines h)
-> GingerContext p (Writer h) h
makeContext' Text
-> GVal
     (ExceptT
        (RuntimeError p)
        (StateT
           (RunState p (Writer h) h)
           (ReaderT (GingerContext p (Writer h) h) (Writer h))))
lookupFn =
    forall (m :: * -> *) p h.
Monad m =>
(Text -> 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'
        (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> GVal
     (ExceptT
        (RuntimeError p)
        (StateT
           (RunState p (Writer h) h)
           (ReaderT (GingerContext p (Writer h) h) (Writer h))))
lookupFn)
        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 :: forall p.
(Text -> GVal (Run p (Writer Html) Html))
-> GingerContext p (Writer Html) Html
makeContext = forall p.
(Text -> 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 :: forall (m :: * -> *) p.
Monad m =>
(Text -> Run p m Html (GVal (Run p m Html)))
-> (Html -> m ()) -> GingerContext p m Html
makeContextM = forall (m :: * -> *) p.
Monad m =>
(Text -> 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 :: forall p.
(Text -> GVal (Run p (Writer Html) Html))
-> GingerContext p (Writer Html) Html
makeContextHtml Text -> GVal (Run p (Writer Html) Html)
l = forall h p.
Monoid h =>
(Text -> GVal (Run p (Writer h) h))
-> (GVal (Run p (Writer h) h) -> h)
-> Maybe (Newlines h)
-> GingerContext p (Writer h) h
makeContext' Text -> GVal (Run p (Writer Html) Html)
l forall s. ToHtml s => s -> Html
toHtml (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 :: forall (m :: * -> *) p.
Monad m =>
(Text -> Run p m Html (GVal (Run p m Html)))
-> (Html -> m ()) -> GingerContext p m Html
makeContextHtmlM Text -> Run p m Html (GVal (Run p m Html))
l Html -> m ()
w = forall (m :: * -> *) p h.
Monad m =>
(Text -> 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' Text -> Run p m Html (GVal (Run p m Html))
l Html -> m ()
w forall s. ToHtml s => s -> Html
toHtml (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 :: forall (m :: * -> *) p.
Monad m =>
(Text -> Run p m Html (GVal (Run p m Html)))
-> (Html -> m ())
-> (RuntimeError p -> m ())
-> GingerContext p m Html
makeContextHtmlExM Text -> Run p m Html (GVal (Run p m Html))
l Html -> m ()
w RuntimeError p -> m ()
warn = forall (m :: * -> *) p h.
Monad m =>
(Text -> 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' Text -> Run p m Html (GVal (Run p m Html))
l Html -> m ()
w RuntimeError p -> m ()
warn forall s. ToHtml s => s -> Html
toHtml (forall a. a -> Maybe a
Just Newlines Html
htmlNewlines)

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

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

makeContextTextExM :: Monad m
                 => (VarName -> Run p m Text (GVal (Run p m Text)))
                 -> (Text -> m ())
                 -> (RuntimeError p -> m ())
                 -> GingerContext p m Text
makeContextTextExM :: forall (m :: * -> *) p.
Monad m =>
(Text -> Run p m Text (GVal (Run p m Text)))
-> (Text -> m ())
-> (RuntimeError p -> m ())
-> GingerContext p m Text
makeContextTextExM Text -> Run p m Text (GVal (Run p m Text))
l Text -> m ()
w RuntimeError p -> m ()
warn = forall (m :: * -> *) p h.
Monad m =>
(Text -> 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' Text -> Run p m Text (GVal (Run p m Text))
l Text -> m ()
w RuntimeError p -> m ()
warn forall (m :: * -> *). GVal m -> Text
asText (forall a. a -> Maybe a
Just Newlines Text
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
        { forall h. Newlines h -> h -> [h]
splitLines :: h -> [h]
        , forall h. Newlines h -> [h] -> h
joinLines :: [h] -> h
        , forall h. Newlines h -> h -> h
stripIndent :: h -> h
        , forall 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 :: forall h t. (h -> t) -> (t -> h) -> Newlines h -> Newlines t
hoistNewlines h -> t
fwd t -> h
rev Newlines h
n =
    Newlines
        { splitLines :: t -> [t]
splitLines = forall a b. (a -> b) -> [a] -> [b]
List.map h -> t
fwd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h. Newlines h -> h -> [h]
splitLines Newlines h
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> h
rev
        , joinLines :: [t] -> t
joinLines = h -> t
fwd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h. Newlines h -> [h] -> h
joinLines Newlines h
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
List.map t -> h
rev
        , stripIndent :: t -> t
stripIndent = h -> t
fwd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h. Newlines h -> h -> h
stripIndent Newlines h
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> h
rev
        , endsWithNewline :: t -> Bool
endsWithNewline = forall h. Newlines h -> h -> Bool
endsWithNewline Newlines h
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> h
rev
        }

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

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

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

data RunState p m h
    = RunState
        { forall p (m :: * -> *) h.
RunState p m h -> HashMap Text (GVal (Run p m h))
rsScope :: HashMap VarName (GVal (Run p m h))
        , forall p (m :: * -> *) h. RunState p m h -> h
rsCapture :: h
        , forall p (m :: * -> *) h. RunState p m h -> Template p
rsCurrentTemplate :: Template p -- the template we are currently running
        , forall p (m :: * -> *) h. RunState p m h -> Maybe Text
rsCurrentBlockName :: Maybe Text -- the name of the innermost block we're currently in
        , forall p (m :: * -> *) h. RunState p m h -> Maybe [h]
rsIndentation :: Maybe [h] -- current indentation level, if any
        , forall p (m :: * -> *) h. RunState p m h -> Bool
rsAtLineStart :: Bool -- is the next output position the first column
        , forall p (m :: * -> *) h. 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 :: 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
rs =
    RunState
        { rsScope :: HashMap Text (GVal (Run p m t))
rsScope = forall (m :: * -> *) (n :: * -> *).
(Functor m, Functor n) =>
(forall a. m a -> n a)
-> (forall a. n a -> m a) -> GVal m -> GVal n
marshalGValEx (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) (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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall p (m :: * -> *) h.
RunState p m h -> HashMap Text (GVal (Run p m h))
rsScope RunState p m h
rs
        , rsCapture :: t
rsCapture = h -> t
fwd forall a b. (a -> b) -> a -> b
$ forall p (m :: * -> *) h. RunState p m h -> h
rsCapture RunState p m h
rs
        , rsCurrentTemplate :: Template p
rsCurrentTemplate = forall p (m :: * -> *) h. RunState p m h -> Template p
rsCurrentTemplate RunState p m h
rs
        , rsCurrentBlockName :: Maybe Text
rsCurrentBlockName = forall p (m :: * -> *) h. RunState p m h -> Maybe Text
rsCurrentBlockName RunState p m h
rs
        , rsIndentation :: Maybe [t]
rsIndentation = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap h -> t
fwd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall p (m :: * -> *) h. RunState p m h -> Maybe [h]
rsIndentation RunState p m h
rs
        , rsAtLineStart :: Bool
rsAtLineStart = forall p (m :: * -> *) h. RunState p m h -> Bool
rsAtLineStart RunState p m h
rs
        , rsCurrentSourcePos :: p
rsCurrentSourcePos = 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
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 = forall p. Text -> RuntimeError p
RuntimeError Text
""

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

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

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

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

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

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

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

rteGVal :: Text -> [(Text, GVal m)] -> [(Text, GVal m)]
rteGVal :: forall (m :: * -> *). Text -> [(Text, GVal m)] -> [(Text, GVal m)]
rteGVal Text
what [(Text, GVal m)]
extra =
    ( [ Text
"what" forall (m :: * -> *) a. ToGVal m a => Text -> a -> Pair m
~> Text
what
      ]
      forall a. [a] -> [a] -> [a]
++ [(Text, 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 :: forall (m :: * -> *) a p h. Monad m => m a -> Run p m h a
liftRun = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall (m :: * -> *) a b p h.
Monad m =>
(a -> m b) -> a -> Run p m h b
liftRun2 a -> m b
f a
x = forall (m :: * -> *) a p h. Monad m => m a -> Run p m h a
liftRun 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 :: 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 Run p m h a
action = do
    GingerContext p m t
contextT <- forall r (m :: * -> *). MonadReader r m => m r
ask
    let contextH :: GingerContext p m h
contextH = 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 <- forall s (m :: * -> *). MonadState s m => m s
get
    let stateH :: RunState p m h
stateH = 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') <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (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' = 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'
    forall s (m :: * -> *). MonadState s m => s -> m ()
put RunState p m t
stateT'
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
Prelude.either forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall (m :: * -> *) a. Monad m => a -> m a
return Either (RuntimeError p) a
x

warn :: (Monad m) => RuntimeError p -> Run p m h ()
warn :: forall (m :: * -> *) p h. Monad m => RuntimeError p -> Run p m h ()
warn RuntimeError p
err = do
    p
pos <- forall (m :: * -> *) p h. Monad m => Run p m h p
getSourcePos
    RuntimeError p -> Run p m h ()
warnFn <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall p (m :: * -> *) h.
GingerContext p m h -> RuntimeError p -> Run p m h ()
contextWarn
    RuntimeError p -> Run p m h ()
warnFn forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *) p a h.
Monad m =>
RuntimeError p -> a -> Maybe a -> Run p m h a
warnFromMaybe RuntimeError p
err a
d Maybe a
Nothing = forall (m :: * -> *) p h. Monad m => RuntimeError p -> Run p m h ()
warn RuntimeError p
err forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
d
warnFromMaybe RuntimeError p
_ a
d (Just a
x) = forall (m :: * -> *) a. Monad m => a -> m a
return a
x

setSourcePos :: Monad m
             => p
             -> Run p m h ()
setSourcePos :: forall (m :: * -> *) p h. Monad m => p -> Run p m h ()
setSourcePos p
pos =
  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 :: forall (m :: * -> *) p h. Monad m => Run p m h p
getSourcePos = forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall p (m :: * -> *) h. RunState p m h -> p
rsCurrentSourcePos

throwHere :: Monad m => RuntimeError p -> Run p m h a
throwHere :: forall (m :: * -> *) p h a.
Monad m =>
RuntimeError p -> Run p m h a
throwHere RuntimeError p
err = do
    p
pos <- forall (m :: * -> *) p h. Monad m => Run p m h p
getSourcePos
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *) p h a.
Monad m =>
p -> Run p m h a -> Run p m h a
withSourcePos p
pos Run p m h a
a = do
  p
oldPos <- forall (m :: * -> *) p h. Monad m => Run p m h p
getSourcePos
  forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError
    (forall (m :: * -> *) p h. Monad m => p -> Run p m h ()
setSourcePos p
pos forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Run p m h a
a forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *) p h. Monad m => p -> Run p m h ()
setSourcePos p
oldPos)
    (\RuntimeError p
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall p. p -> RuntimeError p -> RuntimeError p
RuntimeErrorAt p
oldPos RuntimeError p
err)