{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE ViewPatterns        #-}

module Dovetail.Core.Effect.Exception where

import Control.Monad.Error.Class (catchError)
import Control.Monad.Reader.Class (ask)
import Data.Foldable (fold)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Typeable (Typeable)
import Dovetail
import Dovetail.Evaluate (ForeignType(..), builtIn)

type Error ctx = ForeignType (EvaluationError ctx)

renderValueOptions :: RenderValueOptions
renderValueOptions :: RenderValueOptions
renderValueOptions = RenderValueOptions :: Bool -> Maybe Int -> RenderValueOptions
RenderValueOptions
  { colorOutput :: Bool
colorOutput = Bool
False
  , maximumDepth :: Maybe Int
maximumDepth = Maybe Int
forall a. Maybe a
Nothing
  }

env :: forall ctx. Typeable ctx => Env ctx
env :: Env ctx
env = do
  let _ModuleName :: ModuleName
_ModuleName = Text -> ModuleName
ModuleName Text
"Effect.Exception"

  [Env ctx] -> Env ctx
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
    [ -- throwException :: forall a. Error -> Effect a
      ModuleName
-> Text
-> (Error ctx -> Value ctx -> Eval ctx (Value ctx))
-> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @(Error ctx -> Value ctx -> Eval ctx (Value ctx))
        ModuleName
_ModuleName Text
"throwException" 
        \(ForeignType EvaluationError ctx
e) Value ctx
_ -> 
          EvaluationErrorType ctx -> Eval ctx (Value ctx)
forall x (m :: * -> *) a.
(MonadError (EvaluationError x) m,
 MonadReader (EvaluationContext x) m) =>
EvaluationErrorType x -> m a
throwErrorWithContext (EvaluationError ctx -> EvaluationErrorType ctx
forall ctx. EvaluationError ctx -> EvaluationErrorType ctx
errorType EvaluationError ctx
e)
    , -- catchException :: forall a. (Error -> Effect a) -> Effect a -> Effect a
      ModuleName
-> Text
-> ((Error ctx -> Value ctx -> Eval ctx (Value ctx))
    -> (Value ctx -> Eval ctx (Value ctx))
    -> Value ctx
    -> Eval ctx (Value ctx))
-> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @((Error ctx -> Value ctx -> Eval ctx (Value ctx)) -> (Value ctx -> Eval ctx (Value ctx)) -> Value ctx -> Eval ctx (Value ctx))
        ModuleName
_ModuleName Text
"catchException" 
        \Error ctx -> Value ctx -> Eval ctx (Value ctx)
c Value ctx -> Eval ctx (Value ctx)
t Value ctx
rw -> 
          Eval ctx (Value ctx)
-> (EvaluationError ctx -> Eval ctx (Value ctx))
-> Eval ctx (Value ctx)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (Value ctx -> Eval ctx (Value ctx)
t Value ctx
rw) (\EvaluationError ctx
e -> Error ctx -> Value ctx -> Eval ctx (Value ctx)
c (EvaluationError ctx -> Error ctx
forall a. a -> ForeignType a
ForeignType EvaluationError ctx
e) Value ctx
rw)
      -- showErrorImpl :: Error -> String
    , ModuleName -> Text -> (Error ctx -> Eval ctx Text) -> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @(Error ctx -> Eval ctx Text)
        ModuleName
_ModuleName Text
"showErrorImpl"
        \(ForeignType EvaluationError ctx
e) ->
          Text -> Eval ctx Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Text
Text.pack (RenderValueOptions -> EvaluationError ctx -> String
forall ctx. RenderValueOptions -> EvaluationError ctx -> String
renderEvaluationError RenderValueOptions
renderValueOptions EvaluationError ctx
e))
      -- error :: String -> Error
    , ModuleName -> Text -> (Text -> Eval ctx (Error ctx)) -> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @(Text -> Eval ctx (Error ctx))
        ModuleName
_ModuleName Text
"error"
        \Text
msg -> do
          EvaluationContext [EvaluationStackFrame ctx]
_ ctx
ctx <- Eval ctx (EvaluationContext ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask
          Error ctx -> Eval ctx (Error ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvaluationError ctx -> Error ctx
forall a. a -> ForeignType a
ForeignType (EvaluationErrorType ctx
-> EvaluationContext ctx -> EvaluationError ctx
forall ctx.
EvaluationErrorType ctx
-> EvaluationContext ctx -> EvaluationError ctx
EvaluationError (Text -> EvaluationErrorType ctx
forall ctx. Text -> EvaluationErrorType ctx
OtherError Text
msg) ([EvaluationStackFrame ctx] -> ctx -> EvaluationContext ctx
forall ctx.
[EvaluationStackFrame ctx] -> ctx -> EvaluationContext ctx
EvaluationContext [EvaluationStackFrame ctx]
forall a. Monoid a => a
mempty ctx
ctx)))
      -- message :: Error -> String
    , ModuleName -> Text -> (Error ctx -> Eval ctx Text) -> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @(Error ctx -> Eval ctx Text)
        ModuleName
_ModuleName Text
"message"
        \(ForeignType EvaluationError ctx
e) -> 
          Text -> Eval ctx Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Text
Text.pack (RenderValueOptions -> EvaluationErrorType ctx -> String
forall ctx. RenderValueOptions -> EvaluationErrorType ctx -> String
renderEvaluationErrorType RenderValueOptions
renderValueOptions (EvaluationError ctx -> EvaluationErrorType ctx
forall ctx. EvaluationError ctx -> EvaluationErrorType ctx
errorType EvaluationError ctx
e)))
      -- name :: Error -> String
    , ModuleName -> Text -> (Error ctx -> Eval ctx Text) -> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @(Error ctx -> Eval ctx Text)
        ModuleName
_ModuleName Text
"name"
        \Error ctx
_ ->
          Text -> Eval ctx Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"Error"
      -- stackImpl :: (forall a. a -> Maybe a) -> (forall a. Maybe a) -> Error -> Maybe String
    , ModuleName
-> Text
-> ((Text -> Eval ctx (Value ctx))
    -> Value ctx -> Error ctx -> Eval ctx (Value ctx))
-> Env ctx
forall ctx a. ToValue ctx a => ModuleName -> Text -> a -> Env ctx
builtIn @ctx @((Text -> Eval ctx (Value ctx)) -> Value ctx -> Error ctx -> Eval ctx (Value ctx))
        ModuleName
_ModuleName Text
"stackImpl"
        \Text -> Eval ctx (Value ctx)
_just Value ctx
_nothing (ForeignType EvaluationError ctx
e) ->
          case EvaluationContext ctx -> [EvaluationStackFrame ctx]
forall ctx. EvaluationContext ctx -> [EvaluationStackFrame ctx]
callStack (EvaluationError ctx -> EvaluationContext ctx
forall ctx. EvaluationError ctx -> EvaluationContext ctx
errorContext EvaluationError ctx
e) of
            [] -> Value ctx -> Eval ctx (Value ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value ctx
_nothing
            [EvaluationStackFrame ctx]
stack -> Text -> Eval ctx (Value ctx)
_just ([EvaluationStackFrame ctx] -> Text
forall ctx. [EvaluationStackFrame ctx] -> Text
renderEvaluationStack [EvaluationStackFrame ctx]
stack)
    ]