{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost        #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE TypeApplications           #-}

module Dovetail.Types (
  -- * Evaluation
  -- ** Value types
    Value(..)
  
  -- ** Evaluation monad
  , Env
  , EvalT(..)
  , runEvalT
  , Eval
  , runEval
  
  -- ** Evaluation errors
  , EvaluationError(..)
  , EvaluationErrorType(..)
  , renderEvaluationError
  
  -- ** Evaluation contexts
  , EvaluationContext(..)
  
  -- *** Stack frames
  , EvaluationStackFrame(..)
  , pushStackFrame
  , throwErrorWithContext
  
  -- * Debugging
  , renderValue
  , RenderValueOptions(..)
  , defaultTerminalRenderValueOptions
  ) where
  
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.Fix (MonadFix(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Data.Dynamic (Dynamic)
import Data.Foldable (fold)
import Data.Functor.Identity (Identity(..))
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.List (sortBy)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (listToMaybe)
import Data.Ord (comparing)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Vector (Vector)
import Data.Vector qualified as Vector
import Language.PureScript qualified as P
import Language.PureScript.CoreFn qualified as CoreFn
import Language.PureScript.Errors qualified as Errors
import Language.PureScript.Names (Ident(..), Qualified(..))
import Language.PureScript.Names qualified as Names
import Language.PureScript.PSString qualified as PSString
import System.Console.ANSI.Types qualified as Color

-- | The representation of values used by the interpreter - essentially, the
-- semantic domain for a simple untyped lambda calculus with records and ADTs.
--
-- Any additional side effects which might occur in FFI calls to Haskell code
-- are tracked by a monad in the type argument.
data Value m
  = Object (HashMap Text (Value m))
  -- ^ Records are represented as hashmaps from their field names to values
  | Array (Vector (Value m))
  | String Text
  | Char Char
  | Number Double
  | Int Integer
  | Bool Bool
  | Closure (Value m -> EvalT m (Value m))
  -- ^ Closures, represented in higher-order abstract syntax style.
  | Constructor (Names.ProperName 'Names.ConstructorName) [Value m]
  -- ^ Fully-applied data constructors
  | Foreign Dynamic
  -- ^ Foreign data types

-- | Options when rendering values as strings using 'renderValue'.
data RenderValueOptions = RenderValueOptions
  { RenderValueOptions -> Bool
colorOutput :: Bool
  -- ^ Should ANSI terminal color codes be emitted
  , RenderValueOptions -> Maybe Int
maximumDepth :: Maybe Int
  -- ^ The maximum depth of a subexpression to render, or 'Nothing'
  -- to render the entire 'Value'.
  }

-- | Some sensible default rendering options for use on a terminal
-- which supports color.
defaultTerminalRenderValueOptions :: RenderValueOptions
defaultTerminalRenderValueOptions :: RenderValueOptions
defaultTerminalRenderValueOptions = RenderValueOptions :: Bool -> Maybe Int -> RenderValueOptions
RenderValueOptions
  { colorOutput :: Bool
colorOutput = Bool
True
  , maximumDepth :: Maybe Int
maximumDepth = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  }

-- | Render a 'Value' as human-readable text.
--
-- As a general rule, apart from any closures, the rendered text should evaluate
-- to the value you started with (when 'maximumDepth' is not set).
renderValue :: RenderValueOptions -> Value m -> Text
renderValue :: RenderValueOptions -> Value m -> Text
renderValue RenderValueOptions{ Bool
colorOutput :: Bool
colorOutput :: RenderValueOptions -> Bool
colorOutput, Maybe Int
maximumDepth :: Maybe Int
maximumDepth :: RenderValueOptions -> Maybe Int
maximumDepth } = (Text, Bool) -> Text
forall a b. (a, b) -> a
fst ((Text, Bool) -> Text)
-> (Value m -> (Text, Bool)) -> Value m -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Value m -> (Text, Bool)
forall (m :: * -> *). Int -> Value m -> (Text, Bool)
go Int
0 where
  go :: Int -> Value m -> (Text, Bool)
  go :: Int -> Value m -> (Text, Bool)
go Int
n Value m
_ | Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=) Maybe Int
maximumDepth = (Text
"⋯", Bool
True)
  go Int
_ (String Text
s) = (String -> Text
Text.pack (String -> String
yellow (Text -> String
forall a. Show a => a -> String
show @Text Text
s)), Bool
True)
  go Int
_ (Char Char
c) = (String -> Text
Text.pack (String -> String
yellow (Char -> String
forall a. Show a => a -> String
show @Char Char
c)), Bool
True)
  go Int
_ (Number Double
d) = (String -> Text
Text.pack (String -> String
green (Double -> String
forall a. Show a => a -> String
show @Double Double
d)), Bool
True)
  go Int
_ (Int Integer
i) = (String -> Text
Text.pack (String -> String
green (Integer -> String
forall a. Show a => a -> String
show @Integer Integer
i)), Bool
True)
  go Int
_ (Bool Bool
True) = (String -> Text
Text.pack (String -> String
blue String
"true"), Bool
True)
  go Int
_ (Bool Bool
False) = (String -> Text
Text.pack (String -> String
blue String
"false"), Bool
True)
  go Int
_ (Closure{}) = (String -> Text
Text.pack (String -> String
blue String
"<closure>"), Bool
True)
  go Int
n (Object HashMap Text (Value m)
o) = ( Text
"{ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " 
                      [ String -> Text
Text.pack (String -> String
yellow (Text -> String
forall a. Show a => a -> String
show @Text Text
k)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text, Bool) -> Text
forall a b. (a, b) -> a
fst (Int -> Value m -> (Text, Bool)
forall (m :: * -> *). Int -> Value m -> (Text, Bool)
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Value m
x) 
                      | (Text
k, Value m
x) <- ((Text, Value m) -> (Text, Value m) -> Ordering)
-> [(Text, Value m)] -> [(Text, Value m)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Text, Value m) -> Text)
-> (Text, Value m) -> (Text, Value m) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Text, Value m) -> Text
forall a b. (a, b) -> a
fst) (HashMap Text (Value m) -> [(Text, Value m)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Text (Value m)
o)
                      ] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" }"
                  , Bool
True
                  )
  go Int
n (Array Vector (Value m)
xs) = ( Text
"[ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " 
                       [ (Text, Bool) -> Text
forall a b. (a, b) -> a
fst (Int -> Value m -> (Text, Bool)
forall (m :: * -> *). Int -> Value m -> (Text, Bool)
go (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Value m
x) 
                       | Value m
x <- Vector (Value m) -> [Value m]
forall a. Vector a -> [a]
Vector.toList Vector (Value m)
xs
                       ] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ]"
                  , Bool
True
                  )
  go Int
n (Constructor ProperName 'ConstructorName
ctor [Value m]
args) = ([Text] -> Text
Text.unwords (ProperName 'ConstructorName -> Text
forall (a :: ProperNameType). ProperName a -> Text
P.runProperName ProperName 'ConstructorName
ctor Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Value m -> Text) -> [Value m] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Value m -> Text
forall (m :: * -> *). Int -> Value m -> Text
goParens (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) [Value m]
args), [Value m] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value m]
args)
  go Int
_ (Foreign{}) = (String -> Text
Text.pack (String -> String
blue String
"<foreign>"), Bool
True)

  goParens :: Int -> Value m -> Text
  goParens :: Int -> Value m -> Text
goParens Int
n Value m
x = 
    case Int -> Value m -> (Text, Bool)
forall (m :: * -> *). Int -> Value m -> (Text, Bool)
go Int
n Value m
x of
      (Text
result, Bool
True) -> Text
result
      (Text
result, Bool
False) -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
result Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
      
  color :: (Color.ColorIntensity, Color.Color) -> String -> String
  color :: (ColorIntensity, Color) -> String -> String
color (ColorIntensity, Color)
c 
    | Bool
colorOutput = ((ColorIntensity, Color) -> String
Errors.ansiColor (ColorIntensity, Color)
c String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
Errors.ansiColorReset)
    | Bool
otherwise = String -> String
forall a. a -> a
id

  yellow :: String -> String
  yellow :: String -> String
yellow = (ColorIntensity, Color) -> String -> String
color (ColorIntensity
Color.Dull, Color
Color.Yellow)

  green :: String -> String
  green :: String -> String
green = (ColorIntensity, Color) -> String -> String
color (ColorIntensity
Color.Dull, Color
Color.Green)

  blue :: String -> String
  blue :: String -> String
blue = (ColorIntensity, Color) -> String -> String
color (ColorIntensity
Color.Vivid, Color
Color.Blue)
      
-- | An environment, i.e. a mapping from names to evaluated values.
--
-- An environment for a single built-in function can be constructed
-- using the 'builtIn' function, and environments can be combined
-- easily using the 'Monoid' instance for 'Map'.
type Env m = Map (Qualified Ident) (Value m)

-- | An evaluation context currently consists of an evaluation stack, which
-- is only used for debugging purposes.
--
-- The context type is parameterized by a monad @m@, because stack frames can
-- contain environments, which can in turn contain 'Value's, which may contain
-- monadic closures. This can be useful for inspecting values or resuming execution
-- in the event of an error.
newtype EvaluationContext m = EvaluationContext 
  { EvaluationContext m -> [EvaluationStackFrame m]
getEvaluationContext :: [EvaluationStackFrame m] }
  
-- | A single evaluation stack frame
-- TODO: support frames for foreign function calls
data EvaluationStackFrame m = EvaluationStackFrame
  { EvaluationStackFrame m -> Env m
frameEnv :: Env m
  -- ^ The current environment in this stack frame 
  , EvaluationStackFrame m -> SourceSpan
frameSource :: P.SourceSpan
  -- ^ The source span of the expression whose evaluation created this stack frame.
  , EvaluationStackFrame m -> Expr Ann
frameExpr :: CoreFn.Expr CoreFn.Ann
  -- ^ The expression whose evaluation created this stack frame.
  }
  
-- | Create a stack frame for the evaluation of an expression, and push it onto
-- the stack.
pushStackFrame :: Monad m => Env m -> CoreFn.Expr CoreFn.Ann -> EvalT m a -> EvalT m a
pushStackFrame :: Env m -> Expr Ann -> EvalT m a -> EvalT m a
pushStackFrame Env m
env Expr Ann
expr = 
    (EvaluationContext m -> EvaluationContext m)
-> EvalT m a -> EvalT m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local \(EvaluationContext [EvaluationStackFrame m]
frames) ->
      [EvaluationStackFrame m] -> EvaluationContext m
forall (m :: * -> *).
[EvaluationStackFrame m] -> EvaluationContext m
EvaluationContext (EvaluationStackFrame m
frame EvaluationStackFrame m
-> [EvaluationStackFrame m] -> [EvaluationStackFrame m]
forall a. a -> [a] -> [a]
: [EvaluationStackFrame m]
frames)
  where
    frame :: EvaluationStackFrame m
frame = EvaluationStackFrame :: forall (m :: * -> *).
Env m -> SourceSpan -> Expr Ann -> EvaluationStackFrame m
EvaluationStackFrame 
      { frameEnv :: Env m
frameEnv = Env m
env
      , frameSource :: SourceSpan
frameSource = let (SourceSpan
ss, [Comment]
_, Maybe SourceType
_, Maybe Meta
_) = Expr Ann -> Ann
forall a. Expr a -> a
CoreFn.extractAnn Expr Ann
expr in SourceSpan
ss
      , frameExpr :: Expr Ann
frameExpr = Expr Ann
expr
      }

-- | Throw an error which captures the current execution context.
throwErrorWithContext 
  :: ( MonadError (EvaluationError x) m
     , MonadReader (EvaluationContext x) m
     ) 
  => EvaluationErrorType x
  -> m a
throwErrorWithContext :: EvaluationErrorType x -> m a
throwErrorWithContext EvaluationErrorType x
errorType = do
  EvaluationContext x
errorContext <- m (EvaluationContext x)
forall r (m :: * -> *). MonadReader r m => m r
ask
  EvaluationError x -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError EvaluationError :: forall (m :: * -> *).
EvaluationErrorType m -> EvaluationContext m -> EvaluationError m
EvaluationError 
    { EvaluationErrorType x
errorType :: EvaluationErrorType x
errorType :: EvaluationErrorType x
errorType
    , EvaluationContext x
errorContext :: EvaluationContext x
errorContext :: EvaluationContext x
errorContext
    }
    
-- | The monad used by the interpreter, which supports error reporting for errors
-- which can occur during evaluation.
--
-- The transformed monad is used to track any benign side effects that might be
-- exposed via the foreign function interface to PureScript code.
newtype EvalT m a = EvalT { EvalT m a
-> ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a
unEvalT :: ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a }
  deriving newtype 
    ( a -> EvalT m b -> EvalT m a
(a -> b) -> EvalT m a -> EvalT m b
(forall a b. (a -> b) -> EvalT m a -> EvalT m b)
-> (forall a b. a -> EvalT m b -> EvalT m a) -> Functor (EvalT m)
forall a b. a -> EvalT m b -> EvalT m a
forall a b. (a -> b) -> EvalT m a -> EvalT m b
forall (m :: * -> *) a b. Functor m => a -> EvalT m b -> EvalT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> EvalT m a -> EvalT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> EvalT m b -> EvalT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> EvalT m b -> EvalT m a
fmap :: (a -> b) -> EvalT m a -> EvalT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> EvalT m a -> EvalT m b
Functor
    , Functor (EvalT m)
a -> EvalT m a
Functor (EvalT m)
-> (forall a. a -> EvalT m a)
-> (forall a b. EvalT m (a -> b) -> EvalT m a -> EvalT m b)
-> (forall a b c.
    (a -> b -> c) -> EvalT m a -> EvalT m b -> EvalT m c)
-> (forall a b. EvalT m a -> EvalT m b -> EvalT m b)
-> (forall a b. EvalT m a -> EvalT m b -> EvalT m a)
-> Applicative (EvalT m)
EvalT m a -> EvalT m b -> EvalT m b
EvalT m a -> EvalT m b -> EvalT m a
EvalT m (a -> b) -> EvalT m a -> EvalT m b
(a -> b -> c) -> EvalT m a -> EvalT m b -> EvalT m c
forall a. a -> EvalT m a
forall a b. EvalT m a -> EvalT m b -> EvalT m a
forall a b. EvalT m a -> EvalT m b -> EvalT m b
forall a b. EvalT m (a -> b) -> EvalT m a -> EvalT m b
forall a b c. (a -> b -> c) -> EvalT m a -> EvalT m b -> EvalT m c
forall (m :: * -> *). Monad m => Functor (EvalT m)
forall (m :: * -> *) a. Monad m => a -> EvalT m a
forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> EvalT m b -> EvalT m a
forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> EvalT m b -> EvalT m b
forall (m :: * -> *) a b.
Monad m =>
EvalT m (a -> b) -> EvalT m a -> EvalT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> EvalT m a -> EvalT m b -> EvalT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: EvalT m a -> EvalT m b -> EvalT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> EvalT m b -> EvalT m a
*> :: EvalT m a -> EvalT m b -> EvalT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> EvalT m b -> EvalT m b
liftA2 :: (a -> b -> c) -> EvalT m a -> EvalT m b -> EvalT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> EvalT m a -> EvalT m b -> EvalT m c
<*> :: EvalT m (a -> b) -> EvalT m a -> EvalT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
EvalT m (a -> b) -> EvalT m a -> EvalT m b
pure :: a -> EvalT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> EvalT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (EvalT m)
Applicative
    , Applicative (EvalT m)
a -> EvalT m a
Applicative (EvalT m)
-> (forall a b. EvalT m a -> (a -> EvalT m b) -> EvalT m b)
-> (forall a b. EvalT m a -> EvalT m b -> EvalT m b)
-> (forall a. a -> EvalT m a)
-> Monad (EvalT m)
EvalT m a -> (a -> EvalT m b) -> EvalT m b
EvalT m a -> EvalT m b -> EvalT m b
forall a. a -> EvalT m a
forall a b. EvalT m a -> EvalT m b -> EvalT m b
forall a b. EvalT m a -> (a -> EvalT m b) -> EvalT m b
forall (m :: * -> *). Monad m => Applicative (EvalT m)
forall (m :: * -> *) a. Monad m => a -> EvalT m a
forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> EvalT m b -> EvalT m b
forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> (a -> EvalT m b) -> EvalT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> EvalT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> EvalT m a
>> :: EvalT m a -> EvalT m b -> EvalT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> EvalT m b -> EvalT m b
>>= :: EvalT m a -> (a -> EvalT m b) -> EvalT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
EvalT m a -> (a -> EvalT m b) -> EvalT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (EvalT m)
Monad
    , MonadError (EvaluationError m)
    , MonadReader (EvaluationContext m)
    , Monad (EvalT m)
Monad (EvalT m)
-> (forall a. (a -> EvalT m a) -> EvalT m a) -> MonadFix (EvalT m)
(a -> EvalT m a) -> EvalT m a
forall a. (a -> EvalT m a) -> EvalT m a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
forall (m :: * -> *). MonadFix m => Monad (EvalT m)
forall (m :: * -> *) a. MonadFix m => (a -> EvalT m a) -> EvalT m a
mfix :: (a -> EvalT m a) -> EvalT m a
$cmfix :: forall (m :: * -> *) a. MonadFix m => (a -> EvalT m a) -> EvalT m a
$cp1MonadFix :: forall (m :: * -> *). MonadFix m => Monad (EvalT m)
MonadFix
    )

instance MonadTrans EvalT where
  lift :: m a -> EvalT m a
lift = ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a
-> EvalT m a
forall (m :: * -> *) a.
ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a
-> EvalT m a
EvalT (ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a
 -> EvalT m a)
-> (m a
    -> ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a)
-> m a
-> EvalT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT (EvaluationError m) m a
-> ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (EvaluationError m) m a
 -> ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a)
-> (m a -> ExceptT (EvaluationError m) m a)
-> m a
-> ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ExceptT (EvaluationError m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

runEvalT :: EvalT m a -> m (Either (EvaluationError m) a)
runEvalT :: EvalT m a -> m (Either (EvaluationError m) a)
runEvalT = ExceptT (EvaluationError m) m a -> m (Either (EvaluationError m) a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (EvaluationError m) m a
 -> m (Either (EvaluationError m) a))
-> (EvalT m a -> ExceptT (EvaluationError m) m a)
-> EvalT m a
-> m (Either (EvaluationError m) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a
 -> EvaluationContext m -> ExceptT (EvaluationError m) m a)
-> EvaluationContext m
-> ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a
-> ExceptT (EvaluationError m) m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a
-> EvaluationContext m -> ExceptT (EvaluationError m) m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ([EvaluationStackFrame m] -> EvaluationContext m
forall (m :: * -> *).
[EvaluationStackFrame m] -> EvaluationContext m
EvaluationContext []) (ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a
 -> ExceptT (EvaluationError m) m a)
-> (EvalT m a
    -> ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a)
-> EvalT m a
-> ExceptT (EvaluationError m) m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalT m a
-> ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a
forall (m :: * -> *) a.
EvalT m a
-> ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a
unEvalT

-- | Non-transformer version of `EvalT`, useful in any settings where the FFI
-- does not use any side effects during evaluation.
type Eval = EvalT Identity

runEval :: Eval a -> Either (EvaluationError Identity) a
runEval :: Eval a -> Either (EvaluationError Identity) a
runEval = Identity (Either (EvaluationError Identity) a)
-> Either (EvaluationError Identity) a
forall a. Identity a -> a
runIdentity (Identity (Either (EvaluationError Identity) a)
 -> Either (EvaluationError Identity) a)
-> (Eval a -> Identity (Either (EvaluationError Identity) a))
-> Eval a
-> Either (EvaluationError Identity) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eval a -> Identity (Either (EvaluationError Identity) a)
forall (m :: * -> *) a.
EvalT m a -> m (Either (EvaluationError m) a)
runEvalT

-- | An evaluation error containing the evaluation context at the point the
-- error was raised.
data EvaluationError m = EvaluationError
  { EvaluationError m -> EvaluationErrorType m
errorType :: EvaluationErrorType m
  -- ^ The type of error which was raised
  , EvaluationError m -> EvaluationContext m
errorContext :: EvaluationContext m
  -- ^ The evaluation context at the point the error was raised.
  } 

-- | Errors which can occur during evaluation of PureScript code.
-- 
-- PureScript is a typed language, and tries to prevent runtime errors.
-- However, in the context of this interpreter, we can receive data from outside
-- PureScript code, so it is possible that runtime errors can occur if we are
-- not careful. This is similar to how PureScript code can fail at runtime
-- due to errors in the FFI.
data EvaluationErrorType m
  = UnknownIdent (Qualified Ident)
  -- ^ A name was not found in the environment
  | TypeMismatch Text (Value m)
  -- ^ The runtime representation of a value did not match the expected
  -- representation
  | FieldNotFound Text (Value m)
  -- ^ A record field did not exist in an 'Object' value.
  | InexhaustivePatternMatch [Value m]
  -- ^ A pattern match failed to match its argument
  | InvalidNumberOfArguments Int Int
  -- ^ A pattern match received the wrong number of arguments
  | UnsaturatedConstructorApplication
  -- ^ A pattern match occurred against a partially-applied data constructor
  | InvalidFieldName PSString.PSString
  -- ^ A PureScript string which contains lone surrogates which could not be
  -- decoded. See 'PSString.PSString'.
  | OtherError Text
  -- ^ An error occurred in a foreign function which is not tracked by
  -- any of the other error types.

-- | Render an 'EvaluationError' as a human-readable string.
renderEvaluationError :: RenderValueOptions -> EvaluationError m -> String
renderEvaluationError :: RenderValueOptions -> EvaluationError m -> String
renderEvaluationError RenderValueOptions
opts (EvaluationError{ EvaluationErrorType m
errorType :: EvaluationErrorType m
errorType :: forall (m :: * -> *). EvaluationError m -> EvaluationErrorType m
errorType, EvaluationContext m
errorContext :: EvaluationContext m
errorContext :: forall (m :: * -> *). EvaluationError m -> EvaluationContext m
errorContext }) =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [ String
-> (EvaluationStackFrame m -> String)
-> Maybe (EvaluationStackFrame m)
-> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"Error"
        ((String
"Error " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String)
-> (EvaluationStackFrame m -> String)
-> EvaluationStackFrame m
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack (Text -> String)
-> (EvaluationStackFrame m -> Text)
-> EvaluationStackFrame m
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvaluationStackFrame m -> Text
forall (m :: * -> *). EvaluationStackFrame m -> Text
renderSourceSpan)
        ([EvaluationStackFrame m] -> Maybe (EvaluationStackFrame m)
forall a. [a] -> Maybe a
listToMaybe (EvaluationContext m -> [EvaluationStackFrame m]
forall (m :: * -> *).
EvaluationContext m -> [EvaluationStackFrame m]
getEvaluationContext EvaluationContext m
errorContext))
    ] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<>
    [ String
""
    , String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> RenderValueOptions -> EvaluationErrorType m -> String
forall (m :: * -> *).
RenderValueOptions -> EvaluationErrorType m -> String
renderEvaluationErrorType RenderValueOptions
opts EvaluationErrorType m
errorType
    , String
""
    , String
"In context:"
    ] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ String
"  " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (Ident -> Text
Names.showIdent (Qualified Ident -> Ident
forall a. Qualified a -> a
P.disqualify Qualified Ident
ident))
      , String
"  = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (RenderValueOptions -> Value m -> Text
forall (m :: * -> *). RenderValueOptions -> Value m -> Text
renderValue RenderValueOptions
opts Value m
value)
      , String
""
      ]
    | EvaluationStackFrame m
headFrame <- Int -> [EvaluationStackFrame m] -> [EvaluationStackFrame m]
forall a. Int -> [a] -> [a]
take Int
1 (EvaluationContext m -> [EvaluationStackFrame m]
forall (m :: * -> *).
EvaluationContext m -> [EvaluationStackFrame m]
getEvaluationContext EvaluationContext m
errorContext)
    , (Qualified Ident
ident, Value m
value) <- Map (Qualified Ident) (Value m) -> [(Qualified Ident, Value m)]
forall k a. Map k a -> [(k, a)]
Map.toList (EvaluationStackFrame m -> Map (Qualified Ident) (Value m)
forall (m :: * -> *). EvaluationStackFrame m -> Env m
frameEnv EvaluationStackFrame m
headFrame)
    , Qualified Ident -> Bool
forall a. Qualified a -> Bool
P.isUnqualified Qualified Ident
ident
    ] [String] -> [String] -> [String]
forall a. Semigroup a => a -> a -> a
<> 
    [ Text -> String
Text.unpack (EvaluationStackFrame m -> Text
forall (m :: * -> *). EvaluationStackFrame m -> Text
renderSourceSpan EvaluationStackFrame m
frame)
    | EvaluationStackFrame m
frame <- Int -> [EvaluationStackFrame m] -> [EvaluationStackFrame m]
forall a. Int -> [a] -> [a]
drop Int
1 (EvaluationContext m -> [EvaluationStackFrame m]
forall (m :: * -> *).
EvaluationContext m -> [EvaluationStackFrame m]
getEvaluationContext EvaluationContext m
errorContext)
    ]
  where
    renderSourceSpan :: EvaluationStackFrame m -> Text
renderSourceSpan EvaluationStackFrame m
frame =
      Text
"at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
        [ SourcePos -> Text
P.displaySourcePos (SourceSpan -> SourcePos
P.spanStart (EvaluationStackFrame m -> SourceSpan
forall (m :: * -> *). EvaluationStackFrame m -> SourceSpan
frameSource EvaluationStackFrame m
frame)) 
        , Text
" - " 
        , SourcePos -> Text
P.displaySourcePos (SourceSpan -> SourcePos
P.spanEnd (EvaluationStackFrame m -> SourceSpan
forall (m :: * -> *). EvaluationStackFrame m -> SourceSpan
frameSource EvaluationStackFrame m
frame))
        ]
  
renderEvaluationErrorType :: RenderValueOptions -> EvaluationErrorType m -> String
renderEvaluationErrorType :: RenderValueOptions -> EvaluationErrorType m -> String
renderEvaluationErrorType RenderValueOptions
_ (UnknownIdent Qualified Ident
x) =
  String
"Identifier not in scope: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack ((Ident -> Text) -> Qualified Ident -> Text
forall a. (a -> Text) -> Qualified a -> Text
Names.showQualified Ident -> Text
Names.showIdent Qualified Ident
x)
renderEvaluationErrorType RenderValueOptions
opts (TypeMismatch Text
x Value m
val) =
  String
"Type mismatch, expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", but got value " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (RenderValueOptions -> Value m -> Text
forall (m :: * -> *). RenderValueOptions -> Value m -> Text
renderValue RenderValueOptions
opts Value m
val)
renderEvaluationErrorType RenderValueOptions
opts (FieldNotFound Text
x Value m
val) =
  String
"Record field " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" was not present in value: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (RenderValueOptions -> Value m -> Text
forall (m :: * -> *). RenderValueOptions -> Value m -> Text
renderValue RenderValueOptions
opts Value m
val)
renderEvaluationErrorType RenderValueOptions
_ InexhaustivePatternMatch{} =
  String
"Inexhaustive pattern match"
renderEvaluationErrorType RenderValueOptions
_ (InvalidNumberOfArguments Int
given Int
expected) =
  String
"Invalid number of arguments, given " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
given String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", but expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
expected
renderEvaluationErrorType RenderValueOptions
_ EvaluationErrorType m
UnsaturatedConstructorApplication =
  String
"Unsaturated constructor application"
renderEvaluationErrorType RenderValueOptions
_ (InvalidFieldName PSString
x) =
  String
"Invalid field name: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> PSString -> String
PSString.decodeStringWithReplacement PSString
x
renderEvaluationErrorType RenderValueOptions
_ (OtherError Text
x) =
  String
"Other error: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
x