{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances  #-}

{- |
Module      : Language.Egison.Data
Licence     : MIT

This module contains definitions for Egison internal data.
-}

module Language.Egison.Data
    (
    -- * Egison values
      EgisonValue (..)
    , Matcher
    , PrimitiveFunc
    , LazyPrimitiveFunc
    , EgisonHashKey (..)
    , EgisonData (..)
    , Tensor (..)
    , Shape
    -- * Scalar
    , symbolScalarData
    , symbolScalarData'
    , getSymId
    , getSymName
    , mathExprToEgison
    , egisonToScalarData
    , extractScalar
    -- * Internal data
    , Object (..)
    , ObjectRef
    , WHNFData (..)
    , Inner (..)
    -- * Environment
    , Env (..)
    , Binding
    , nullEnv
    , extendEnv
    , refVar
    -- * Errors
    , EgisonError (..)
    , throwErrorWithTrace
    -- * Monads
    , EvalM
    , fromEvalM
    , fromEvalT
    ) where

import           Control.Exception

import           Control.Monad.Except             hiding (join)
import           Control.Monad.Trans.State.Strict

import           Data.Foldable                    (toList)
import           Data.HashMap.Strict              (HashMap)
import qualified Data.HashMap.Strict              as HashMap
import           Data.IORef
import           Data.Sequence                    (Seq)
import qualified Data.Sequence                    as Sq
import qualified Data.Vector                      as V

import           Data.List                        (intercalate)
import           Data.Text                        (Text)
import           Text.Show.Unicode                (ushow)

import           Data.Ratio
import           System.IO

import           Language.Egison.CmdOptions
import           Language.Egison.EvalState
import           Language.Egison.IExpr
import           Language.Egison.Math
import           Language.Egison.RState

--
-- Values
--

data EgisonValue
  = World
  | Char Char
  | String Text
  | Bool Bool
  | ScalarData ScalarData
  | TensorData (Tensor EgisonValue)
  | Float Double
  | InductiveData String [EgisonValue]
  | Tuple [EgisonValue]
  | Collection (Seq EgisonValue)
  | IntHash (HashMap Integer EgisonValue)
  | CharHash (HashMap Char EgisonValue)
  | StrHash (HashMap Text EgisonValue)
  | UserMatcher Env [IPatternDef]
  | Func (Maybe Var) Env [Var] IExpr
  | CFunc Env String IExpr
  | MemoizedFunc (IORef (HashMap [Integer] WHNFData)) Env [String] IExpr
  | PatternFunc Env [String] IPattern
  | PrimitiveFunc PrimitiveFunc
  | LazyPrimitiveFunc LazyPrimitiveFunc
  | IOFunc (EvalM WHNFData)
  | Port Handle
  | RefBox (IORef EgisonValue)
  | Something
  | Undefined

type Matcher = EgisonValue

type PrimitiveFunc = [EgisonValue] -> EvalM EgisonValue
type LazyPrimitiveFunc = [WHNFData] -> EvalM WHNFData

data EgisonHashKey
  = IntKey Integer
  | CharKey Char
  | StrKey Text

--
-- Scalar and Tensor Types
--

data Tensor a
  = Tensor Shape (V.Vector a) [Index EgisonValue]
  | Scalar a
 deriving Int -> Tensor a -> ShowS
[Tensor a] -> ShowS
Tensor a -> String
(Int -> Tensor a -> ShowS)
-> (Tensor a -> String) -> ([Tensor a] -> ShowS) -> Show (Tensor a)
forall a. Show a => Int -> Tensor a -> ShowS
forall a. Show a => [Tensor a] -> ShowS
forall a. Show a => Tensor a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tensor a] -> ShowS
$cshowList :: forall a. Show a => [Tensor a] -> ShowS
show :: Tensor a -> String
$cshow :: forall a. Show a => Tensor a -> String
showsPrec :: Int -> Tensor a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Tensor a -> ShowS
Show

type Shape = [Integer]

--
-- Scalars
--

symbolScalarData :: String -> String -> EgisonValue
symbolScalarData :: String -> String -> EgisonValue
symbolScalarData String
id String
name = ScalarData -> EgisonValue
ScalarData (Integer -> Monomial -> ScalarData
SingleTerm Integer
1 [(String -> String -> [Index ScalarData] -> SymbolExpr
Symbol String
id String
name [], Integer
1)])

symbolScalarData' :: String -> ScalarData
symbolScalarData' :: String -> ScalarData
symbolScalarData' String
name = Integer -> Monomial -> ScalarData
SingleTerm Integer
1 [(String -> String -> [Index ScalarData] -> SymbolExpr
Symbol String
"" String
name [], Integer
1)]

getSymId :: EgisonValue -> String
getSymId :: EgisonValue -> String
getSymId (ScalarData (SingleTerm Integer
1 [(Symbol String
id String
_ [Index ScalarData]
_, Integer
_)])) = String
id

getSymName :: EgisonValue -> String
getSymName :: EgisonValue -> String
getSymName (ScalarData (SingleTerm Integer
1 [(Symbol String
_ String
name [], Integer
1)])) = String
name

mathExprToEgison :: ScalarData -> EgisonValue
mathExprToEgison :: ScalarData -> EgisonValue
mathExprToEgison (Div PolyExpr
p1 PolyExpr
p2) = String -> [EgisonValue] -> EgisonValue
InductiveData String
"Div" [PolyExpr -> EgisonValue
polyExprToEgison PolyExpr
p1, PolyExpr -> EgisonValue
polyExprToEgison PolyExpr
p2]

polyExprToEgison :: PolyExpr -> EgisonValue
polyExprToEgison :: PolyExpr -> EgisonValue
polyExprToEgison (Plus [TermExpr]
ts) = String -> [EgisonValue] -> EgisonValue
InductiveData String
"Plus" [Seq EgisonValue -> EgisonValue
Collection ([EgisonValue] -> Seq EgisonValue
forall a. [a] -> Seq a
Sq.fromList ((TermExpr -> EgisonValue) -> [TermExpr] -> [EgisonValue]
forall a b. (a -> b) -> [a] -> [b]
map TermExpr -> EgisonValue
termExprToEgison [TermExpr]
ts))]

termExprToEgison :: TermExpr -> EgisonValue
termExprToEgison :: TermExpr -> EgisonValue
termExprToEgison (Term Integer
a Monomial
xs) = String -> [EgisonValue] -> EgisonValue
InductiveData String
"Term" [Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison Integer
a, Seq EgisonValue -> EgisonValue
Collection ([EgisonValue] -> Seq EgisonValue
forall a. [a] -> Seq a
Sq.fromList (((SymbolExpr, Integer) -> EgisonValue) -> Monomial -> [EgisonValue]
forall a b. (a -> b) -> [a] -> [b]
map (SymbolExpr, Integer) -> EgisonValue
symbolExprToEgison Monomial
xs))]

symbolExprToEgison :: (SymbolExpr, Integer) -> EgisonValue
symbolExprToEgison :: (SymbolExpr, Integer) -> EgisonValue
symbolExprToEgison (Symbol String
id String
x [Index ScalarData]
js, Integer
n) = [EgisonValue] -> EgisonValue
Tuple [String -> [EgisonValue] -> EgisonValue
InductiveData String
"Symbol" [String -> String -> EgisonValue
symbolScalarData String
id String
x, [Index ScalarData] -> EgisonValue
f [Index ScalarData]
js], Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison Integer
n]
 where
  f :: [Index ScalarData] -> EgisonValue
f [Index ScalarData]
js = Seq EgisonValue -> EgisonValue
Collection ([EgisonValue] -> Seq EgisonValue
forall a. [a] -> Seq a
Sq.fromList ((Index ScalarData -> EgisonValue)
-> [Index ScalarData] -> [EgisonValue]
forall a b. (a -> b) -> [a] -> [b]
map Index ScalarData -> EgisonValue
scalarIndexToEgison [Index ScalarData]
js))
symbolExprToEgison (Apply ScalarData
fn [ScalarData]
mExprs, Integer
n) = [EgisonValue] -> EgisonValue
Tuple [String -> [EgisonValue] -> EgisonValue
InductiveData String
"Apply" [ScalarData -> EgisonValue
ScalarData ScalarData
fn, Seq EgisonValue -> EgisonValue
Collection ([EgisonValue] -> Seq EgisonValue
forall a. [a] -> Seq a
Sq.fromList ((ScalarData -> EgisonValue) -> [ScalarData] -> [EgisonValue]
forall a b. (a -> b) -> [a] -> [b]
map ScalarData -> EgisonValue
mathExprToEgison [ScalarData]
mExprs))], Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison Integer
n]
symbolExprToEgison (Quote ScalarData
mExpr, Integer
n) = [EgisonValue] -> EgisonValue
Tuple [String -> [EgisonValue] -> EgisonValue
InductiveData String
"Quote" [ScalarData -> EgisonValue
mathExprToEgison ScalarData
mExpr], Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison Integer
n]
symbolExprToEgison (FunctionData ScalarData
name [ScalarData]
argnames [ScalarData]
args, Integer
n) =
  [EgisonValue] -> EgisonValue
Tuple [String -> [EgisonValue] -> EgisonValue
InductiveData String
"Function" [ScalarData -> EgisonValue
ScalarData ScalarData
name, Seq EgisonValue -> EgisonValue
Collection ([EgisonValue] -> Seq EgisonValue
forall a. [a] -> Seq a
Sq.fromList ((ScalarData -> EgisonValue) -> [ScalarData] -> [EgisonValue]
forall a b. (a -> b) -> [a] -> [b]
map ScalarData -> EgisonValue
ScalarData [ScalarData]
argnames)), Seq EgisonValue -> EgisonValue
Collection ([EgisonValue] -> Seq EgisonValue
forall a. [a] -> Seq a
Sq.fromList ((ScalarData -> EgisonValue) -> [ScalarData] -> [EgisonValue]
forall a b. (a -> b) -> [a] -> [b]
map ScalarData -> EgisonValue
ScalarData [ScalarData]
args))], Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison Integer
n]

scalarIndexToEgison :: Index ScalarData -> EgisonValue
scalarIndexToEgison :: Index ScalarData -> EgisonValue
scalarIndexToEgison (Sup ScalarData
k)  = String -> [EgisonValue] -> EgisonValue
InductiveData String
"Sup"  [ScalarData -> EgisonValue
ScalarData ScalarData
k]
scalarIndexToEgison (Sub ScalarData
k)  = String -> [EgisonValue] -> EgisonValue
InductiveData String
"Sub"  [ScalarData -> EgisonValue
ScalarData ScalarData
k]
scalarIndexToEgison (User ScalarData
k) = String -> [EgisonValue] -> EgisonValue
InductiveData String
"User" [ScalarData -> EgisonValue
ScalarData ScalarData
k]

-- Implementation of 'toMathExpr' (Primitive function)
egisonToScalarData :: EgisonValue -> EvalM ScalarData
egisonToScalarData :: EgisonValue -> EvalM ScalarData
egisonToScalarData (InductiveData String
"Div" [EgisonValue
p1, EgisonValue
p2]) = PolyExpr -> PolyExpr -> ScalarData
Div (PolyExpr -> PolyExpr -> ScalarData)
-> StateT EvalState (ExceptT EgisonError RuntimeM) PolyExpr
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (PolyExpr -> ScalarData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) PolyExpr
egisonToPolyExpr EgisonValue
p1 StateT
  EvalState (ExceptT EgisonError RuntimeM) (PolyExpr -> ScalarData)
-> StateT EvalState (ExceptT EgisonError RuntimeM) PolyExpr
-> EvalM ScalarData
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) PolyExpr
egisonToPolyExpr EgisonValue
p2
egisonToScalarData p1 :: EgisonValue
p1@(InductiveData String
"Plus" [EgisonValue]
_) = PolyExpr -> PolyExpr -> ScalarData
Div (PolyExpr -> PolyExpr -> ScalarData)
-> StateT EvalState (ExceptT EgisonError RuntimeM) PolyExpr
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (PolyExpr -> ScalarData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) PolyExpr
egisonToPolyExpr EgisonValue
p1 StateT
  EvalState (ExceptT EgisonError RuntimeM) (PolyExpr -> ScalarData)
-> StateT EvalState (ExceptT EgisonError RuntimeM) PolyExpr
-> EvalM ScalarData
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PolyExpr
-> StateT EvalState (ExceptT EgisonError RuntimeM) PolyExpr
forall (m :: * -> *) a. Monad m => a -> m a
return ([TermExpr] -> PolyExpr
Plus [Integer -> Monomial -> TermExpr
Term Integer
1 []])
egisonToScalarData t1 :: EgisonValue
t1@(InductiveData String
"Term" [EgisonValue]
_) = do
  TermExpr
t1' <- EgisonValue -> EvalM TermExpr
egisonToTermExpr EgisonValue
t1
  ScalarData -> EvalM ScalarData
forall (m :: * -> *) a. Monad m => a -> m a
return (ScalarData -> EvalM ScalarData) -> ScalarData -> EvalM ScalarData
forall a b. (a -> b) -> a -> b
$ PolyExpr -> PolyExpr -> ScalarData
Div ([TermExpr] -> PolyExpr
Plus [TermExpr
t1']) ([TermExpr] -> PolyExpr
Plus [Integer -> Monomial -> TermExpr
Term Integer
1 []])
egisonToScalarData s1 :: EgisonValue
s1@(InductiveData String
"Symbol" [EgisonValue]
_) = do
  (SymbolExpr, Integer)
s1' <- EgisonValue -> EvalM (SymbolExpr, Integer)
egisonToSymbolExpr ([EgisonValue] -> EgisonValue
Tuple [EgisonValue
s1, Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison (Integer
1 ::Integer)])
  ScalarData -> EvalM ScalarData
forall (m :: * -> *) a. Monad m => a -> m a
return (ScalarData -> EvalM ScalarData) -> ScalarData -> EvalM ScalarData
forall a b. (a -> b) -> a -> b
$ Integer -> Monomial -> ScalarData
SingleTerm Integer
1 [(SymbolExpr, Integer)
s1']
egisonToScalarData s1 :: EgisonValue
s1@(InductiveData String
"Apply" [EgisonValue]
_) = do
  (SymbolExpr, Integer)
s1' <- EgisonValue -> EvalM (SymbolExpr, Integer)
egisonToSymbolExpr ([EgisonValue] -> EgisonValue
Tuple [EgisonValue
s1, Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison (Integer
1 :: Integer)])
  ScalarData -> EvalM ScalarData
forall (m :: * -> *) a. Monad m => a -> m a
return (ScalarData -> EvalM ScalarData) -> ScalarData -> EvalM ScalarData
forall a b. (a -> b) -> a -> b
$ Integer -> Monomial -> ScalarData
SingleTerm Integer
1 [(SymbolExpr, Integer)
s1']
egisonToScalarData s1 :: EgisonValue
s1@(InductiveData String
"Quote" [EgisonValue]
_) = do
  (SymbolExpr, Integer)
s1' <- EgisonValue -> EvalM (SymbolExpr, Integer)
egisonToSymbolExpr ([EgisonValue] -> EgisonValue
Tuple [EgisonValue
s1, Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison (Integer
1 :: Integer)])
  ScalarData -> EvalM ScalarData
forall (m :: * -> *) a. Monad m => a -> m a
return (ScalarData -> EvalM ScalarData) -> ScalarData -> EvalM ScalarData
forall a b. (a -> b) -> a -> b
$ Integer -> Monomial -> ScalarData
SingleTerm Integer
1 [(SymbolExpr, Integer)
s1']
egisonToScalarData s1 :: EgisonValue
s1@(InductiveData String
"Function" [EgisonValue]
_) = do
  (SymbolExpr, Integer)
s1' <- EgisonValue -> EvalM (SymbolExpr, Integer)
egisonToSymbolExpr ([EgisonValue] -> EgisonValue
Tuple [EgisonValue
s1, Integer -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison (Integer
1 :: Integer)])
  ScalarData -> EvalM ScalarData
forall (m :: * -> *) a. Monad m => a -> m a
return (ScalarData -> EvalM ScalarData) -> ScalarData -> EvalM ScalarData
forall a b. (a -> b) -> a -> b
$ Integer -> Monomial -> ScalarData
SingleTerm Integer
1 [(SymbolExpr, Integer)
s1']
egisonToScalarData EgisonValue
val = (CallStack -> EgisonError) -> EvalM ScalarData
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"math expression" (EgisonValue -> WHNFData
Value EgisonValue
val))

egisonToPolyExpr :: EgisonValue -> EvalM PolyExpr
egisonToPolyExpr :: EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) PolyExpr
egisonToPolyExpr (InductiveData String
"Plus" [Collection Seq EgisonValue
ts]) = [TermExpr] -> PolyExpr
Plus ([TermExpr] -> PolyExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) [TermExpr]
-> StateT EvalState (ExceptT EgisonError RuntimeM) PolyExpr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EgisonValue -> EvalM TermExpr)
-> [EgisonValue]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [TermExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM EgisonValue -> EvalM TermExpr
egisonToTermExpr (Seq EgisonValue -> [EgisonValue]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq EgisonValue
ts)
egisonToPolyExpr EgisonValue
val                                    = (CallStack -> EgisonError)
-> StateT EvalState (ExceptT EgisonError RuntimeM) PolyExpr
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"math poly expression" (EgisonValue -> WHNFData
Value EgisonValue
val))

egisonToTermExpr :: EgisonValue -> EvalM TermExpr
egisonToTermExpr :: EgisonValue -> EvalM TermExpr
egisonToTermExpr (InductiveData String
"Term" [EgisonValue
n, Collection Seq EgisonValue
ts]) = Integer -> Monomial -> TermExpr
Term (Integer -> Monomial -> TermExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (Monomial -> TermExpr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison EgisonValue
n StateT
  EvalState (ExceptT EgisonError RuntimeM) (Monomial -> TermExpr)
-> StateT EvalState (ExceptT EgisonError RuntimeM) Monomial
-> EvalM TermExpr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (EgisonValue -> EvalM (SymbolExpr, Integer))
-> [EgisonValue]
-> StateT EvalState (ExceptT EgisonError RuntimeM) Monomial
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM EgisonValue -> EvalM (SymbolExpr, Integer)
egisonToSymbolExpr (Seq EgisonValue -> [EgisonValue]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq EgisonValue
ts)
egisonToTermExpr EgisonValue
val                                       = (CallStack -> EgisonError) -> EvalM TermExpr
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"math term expression" (EgisonValue -> WHNFData
Value EgisonValue
val))

egisonToSymbolExpr :: EgisonValue -> EvalM (SymbolExpr, Integer)
egisonToSymbolExpr :: EgisonValue -> EvalM (SymbolExpr, Integer)
egisonToSymbolExpr (Tuple [InductiveData String
"Symbol" [EgisonValue
x, Collection Seq EgisonValue
seq], EgisonValue
n]) = do
  let js :: [EgisonValue]
js = Seq EgisonValue -> [EgisonValue]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq EgisonValue
seq
  [Index ScalarData]
js' <- (EgisonValue
 -> StateT
      EvalState (ExceptT EgisonError RuntimeM) (Index ScalarData))
-> [EgisonValue]
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) [Index ScalarData]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM EgisonValue
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (Index ScalarData)
egisonToScalarIndex [EgisonValue]
js
  Integer
n' <- EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison EgisonValue
n
  case EgisonValue
x of
    (ScalarData (Div (Plus [Term Integer
1 [(Symbol String
id String
name [], Integer
1)]]) (Plus [Term Integer
1 []]))) ->
      (SymbolExpr, Integer) -> EvalM (SymbolExpr, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> [Index ScalarData] -> SymbolExpr
Symbol String
id String
name [Index ScalarData]
js', Integer
n')
egisonToSymbolExpr (Tuple [InductiveData String
"Apply" [EgisonValue
fn, Collection Seq EgisonValue
mExprs], EgisonValue
n]) = do
  ScalarData
fn' <- EgisonValue -> EvalM ScalarData
extractScalar EgisonValue
fn
  [ScalarData]
mExprs' <- (EgisonValue -> EvalM ScalarData)
-> [EgisonValue]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [ScalarData]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM EgisonValue -> EvalM ScalarData
egisonToScalarData (Seq EgisonValue -> [EgisonValue]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq EgisonValue
mExprs)
  Integer
n' <- EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison EgisonValue
n
  (SymbolExpr, Integer) -> EvalM (SymbolExpr, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScalarData -> [ScalarData] -> SymbolExpr
Apply ScalarData
fn' [ScalarData]
mExprs', Integer
n')
egisonToSymbolExpr (Tuple [InductiveData String
"Quote" [EgisonValue
mExpr], EgisonValue
n]) = do
  ScalarData
mExpr' <- EgisonValue -> EvalM ScalarData
egisonToScalarData EgisonValue
mExpr
  Integer
n' <- EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison EgisonValue
n
  (SymbolExpr, Integer) -> EvalM (SymbolExpr, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScalarData -> SymbolExpr
Quote ScalarData
mExpr', Integer
n')
egisonToSymbolExpr (Tuple [InductiveData String
"Function" [EgisonValue
name, Collection Seq EgisonValue
argnames, Collection Seq EgisonValue
args], EgisonValue
n]) = do
  ScalarData
name' <- EgisonValue -> EvalM ScalarData
extractScalar EgisonValue
name
  [ScalarData]
argnames' <- (EgisonValue -> EvalM ScalarData)
-> [EgisonValue]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [ScalarData]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM EgisonValue -> EvalM ScalarData
extractScalar (Seq EgisonValue -> [EgisonValue]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq EgisonValue
argnames)
  [ScalarData]
args' <- (EgisonValue -> EvalM ScalarData)
-> [EgisonValue]
-> StateT EvalState (ExceptT EgisonError RuntimeM) [ScalarData]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM EgisonValue -> EvalM ScalarData
extractScalar (Seq EgisonValue -> [EgisonValue]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq EgisonValue
args)
  Integer
n' <- EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison EgisonValue
n
  (SymbolExpr, Integer) -> EvalM (SymbolExpr, Integer)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScalarData -> [ScalarData] -> [ScalarData] -> SymbolExpr
FunctionData ScalarData
name' [ScalarData]
argnames' [ScalarData]
args', Integer
n')
egisonToSymbolExpr EgisonValue
val = (CallStack -> EgisonError) -> EvalM (SymbolExpr, Integer)
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"math symbol expression" (EgisonValue -> WHNFData
Value EgisonValue
val))

egisonToScalarIndex :: EgisonValue -> EvalM (Index ScalarData)
egisonToScalarIndex :: EgisonValue
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (Index ScalarData)
egisonToScalarIndex EgisonValue
j = case EgisonValue
j of
  InductiveData String
"Sup"  [ScalarData ScalarData
k] -> Index ScalarData
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (Index ScalarData)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScalarData -> Index ScalarData
forall a. a -> Index a
Sup ScalarData
k)
  InductiveData String
"Sub"  [ScalarData ScalarData
k] -> Index ScalarData
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (Index ScalarData)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScalarData -> Index ScalarData
forall a. a -> Index a
Sub ScalarData
k)
  InductiveData String
"User" [ScalarData ScalarData
k] -> Index ScalarData
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (Index ScalarData)
forall (m :: * -> *) a. Monad m => a -> m a
return (ScalarData -> Index ScalarData
forall a. a -> Index a
User ScalarData
k)
  EgisonValue
_                                   -> (CallStack -> EgisonError)
-> StateT
     EvalState (ExceptT EgisonError RuntimeM) (Index ScalarData)
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"math symbol expression" (EgisonValue -> WHNFData
Value EgisonValue
j))

--
-- ExtractScalar
--

extractScalar :: EgisonValue -> EvalM ScalarData
extractScalar :: EgisonValue -> EvalM ScalarData
extractScalar (ScalarData ScalarData
mExpr) = ScalarData -> EvalM ScalarData
forall (m :: * -> *) a. Monad m => a -> m a
return ScalarData
mExpr
extractScalar EgisonValue
val                = (CallStack -> EgisonError) -> EvalM ScalarData
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"math expression" (EgisonValue -> WHNFData
Value EgisonValue
val))

-- New-syntax version of EgisonValue pretty printer.
-- TODO(momohatt): Don't make it a show instance of EgisonValue.
instance Show EgisonValue where
  show :: EgisonValue -> String
show (Char Char
c) = Char
'\'' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: String
"'"
  show (String Text
str) = Text -> String
forall a. Show a => a -> String
ushow Text
str
  show (Bool Bool
True) = String
"True"
  show (Bool Bool
False) = String
"False"
  show (ScalarData ScalarData
mExpr) = ScalarData -> String
forall a. Show a => a -> String
show ScalarData
mExpr
  show (TensorData (Tensor [Integer
_] Vector EgisonValue
xs [Index EgisonValue]
js)) = String
"[| " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((EgisonValue -> String) -> [EgisonValue] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map EgisonValue -> String
forall a. Show a => a -> String
show (Vector EgisonValue -> [EgisonValue]
forall a. Vector a -> [a]
V.toList Vector EgisonValue
xs)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" |]" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Index EgisonValue -> String) -> [Index EgisonValue] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Index EgisonValue -> String
forall a. Show a => a -> String
show [Index EgisonValue]
js
  show (TensorData (Tensor [Integer
0, Integer
0] Vector EgisonValue
_ [Index EgisonValue]
js)) = String
"[| [|  |] |]" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Index EgisonValue -> String) -> [Index EgisonValue] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Index EgisonValue -> String
forall a. Show a => a -> String
show [Index EgisonValue]
js
  show (TensorData (Tensor [Integer
_, Integer
j] Vector EgisonValue
xs [Index EgisonValue]
js)) = String
"[| " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (Int -> [EgisonValue] -> [String]
forall a. Show a => Int -> [a] -> [String]
f (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
j) (Vector EgisonValue -> [EgisonValue]
forall a. Vector a -> [a]
V.toList Vector EgisonValue
xs)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" |]" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Index EgisonValue -> String) -> [Index EgisonValue] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Index EgisonValue -> String
forall a. Show a => a -> String
show [Index EgisonValue]
js
    where
      f :: Int -> [a] -> [String]
f Int
_ [] = []
      f Int
j [a]
xs = (String
"[| " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Show a => a -> String
show (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
j [a]
xs)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" |]") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Int -> [a] -> [String]
f Int
j (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
j [a]
xs)
  show (TensorData (Tensor [Integer]
ns Vector EgisonValue
xs [Index EgisonValue]
js)) = String
"(tensor [" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Integer -> String) -> [Integer] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> String
forall a. Show a => a -> String
show [Integer]
ns) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] [" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((EgisonValue -> String) -> [EgisonValue] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map EgisonValue -> String
forall a. Show a => a -> String
show (Vector EgisonValue -> [EgisonValue]
forall a. Vector a -> [a]
V.toList Vector EgisonValue
xs)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] )" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Index EgisonValue -> String) -> [Index EgisonValue] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Index EgisonValue -> String
forall a. Show a => a -> String
show [Index EgisonValue]
js
  show (Float Double
x) = Double -> String
forall a. Show a => a -> String
show Double
x
  show (InductiveData String
name [EgisonValue]
vals) = String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ (EgisonValue -> String) -> [EgisonValue] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((Char
' 'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> (EgisonValue -> String) -> EgisonValue -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EgisonValue -> String
show') [EgisonValue]
vals
    where
      show' :: EgisonValue -> String
show' EgisonValue
x | EgisonValue -> Bool
isAtomic EgisonValue
x = EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
x
              | Bool
otherwise  = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  show (Tuple [EgisonValue]
vals)      = String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((EgisonValue -> String) -> [EgisonValue] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map EgisonValue -> String
forall a. Show a => a -> String
show [EgisonValue]
vals) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
  show (Collection Seq EgisonValue
vals) = String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((EgisonValue -> String) -> [EgisonValue] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map EgisonValue -> String
forall a. Show a => a -> String
show (Seq EgisonValue -> [EgisonValue]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq EgisonValue
vals)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
  show (IntHash HashMap Integer EgisonValue
hash)  = String
"{|" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (((Integer, EgisonValue) -> String)
-> [(Integer, EgisonValue)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Integer
key, EgisonValue
val) -> String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
val String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]") ([(Integer, EgisonValue)] -> [String])
-> [(Integer, EgisonValue)] -> [String]
forall a b. (a -> b) -> a -> b
$ HashMap Integer EgisonValue -> [(Integer, EgisonValue)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Integer EgisonValue
hash) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"|}"
  show (CharHash HashMap Char EgisonValue
hash) = String
"{|" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (((Char, EgisonValue) -> String)
-> [(Char, EgisonValue)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Char
key, EgisonValue
val) -> String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
val String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]") ([(Char, EgisonValue)] -> [String])
-> [(Char, EgisonValue)] -> [String]
forall a b. (a -> b) -> a -> b
$ HashMap Char EgisonValue -> [(Char, EgisonValue)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Char EgisonValue
hash) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"|}"
  show (StrHash HashMap Text EgisonValue
hash)  = String
"{|" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (((Text, EgisonValue) -> String)
-> [(Text, EgisonValue)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
key, EgisonValue
val) -> String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
key String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
val String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]") ([(Text, EgisonValue)] -> [String])
-> [(Text, EgisonValue)] -> [String]
forall a b. (a -> b) -> a -> b
$ HashMap Text EgisonValue -> [(Text, EgisonValue)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Text EgisonValue
hash) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"|}"
  show UserMatcher{} = String
"#<user-matcher>"
  show (Func Maybe Var
_ Env
_ CallStack
args IExpr
_) = String
"#<lambda [" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Var -> String) -> CallStack -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Var -> String
forall a. Show a => a -> String
show CallStack
args) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] ...>"
  show (CFunc Env
_ String
name IExpr
_) = String
"#<cambda " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ...>"
  show (MemoizedFunc IORef (HashMap [Integer] WHNFData)
_ Env
_ [String]
names IExpr
_) = String
"#<memoized-lambda [" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
names String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] ...>"
  show PatternFunc{} = String
"#<pattern-function>"
  show PrimitiveFunc{} = String
"#<primitive-function>"
  show LazyPrimitiveFunc{} = String
"#<primitive-function>"
  show IOFunc{} = String
"#<io-function>"
  show Port{}   = String
"#<port>"
  show RefBox{} = String
"#<refbox>"
  show EgisonValue
Something = String
"something"
  show EgisonValue
Undefined = String
"undefined"
  show EgisonValue
World = String
"#<world>"

-- False if we have to put parenthesis around it to make it an atomic expression.
isAtomic :: EgisonValue -> Bool
isAtomic :: EgisonValue -> Bool
isAtomic (InductiveData String
_ []) = Bool
True
isAtomic (InductiveData String
_ [EgisonValue]
_)  = Bool
False
isAtomic (ScalarData ScalarData
m)       = ScalarData -> Bool
forall a. Printable a => a -> Bool
isAtom ScalarData
m
isAtomic EgisonValue
_                    = Bool
True

instance Eq EgisonValue where
  (Char Char
c) == :: EgisonValue -> EgisonValue -> Bool
== (Char Char
c')                                            = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c'
  (String Text
str) == (String Text
str')                                    = Text
str Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
str'
  (Bool Bool
b) == (Bool Bool
b')                                            = Bool
b Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b'
  (ScalarData ScalarData
x) == (ScalarData ScalarData
y)                                 = ScalarData
x ScalarData -> ScalarData -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarData
y
  (TensorData (Tensor [Integer]
js Vector EgisonValue
xs [Index EgisonValue]
_)) == (TensorData (Tensor [Integer]
js' Vector EgisonValue
xs' [Index EgisonValue]
_)) = [Integer]
js [Integer] -> [Integer] -> Bool
forall a. Eq a => a -> a -> Bool
== [Integer]
js' Bool -> Bool -> Bool
&& Vector EgisonValue
xs Vector EgisonValue -> Vector EgisonValue -> Bool
forall a. Eq a => a -> a -> Bool
== Vector EgisonValue
xs'
  (Float Double
x) == (Float Double
x')                                          = Double
x Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Double
x'
  (InductiveData String
name [EgisonValue]
vals) == (InductiveData String
name' [EgisonValue]
vals')         = String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name' Bool -> Bool -> Bool
&& [EgisonValue]
vals [EgisonValue] -> [EgisonValue] -> Bool
forall a. Eq a => a -> a -> Bool
== [EgisonValue]
vals'
  (Tuple [EgisonValue]
vals) == (Tuple [EgisonValue]
vals')                                    = [EgisonValue]
vals [EgisonValue] -> [EgisonValue] -> Bool
forall a. Eq a => a -> a -> Bool
== [EgisonValue]
vals'
  (Collection Seq EgisonValue
vals) == (Collection Seq EgisonValue
vals')                          = Seq EgisonValue
vals Seq EgisonValue -> Seq EgisonValue -> Bool
forall a. Eq a => a -> a -> Bool
== Seq EgisonValue
vals'
  (IntHash HashMap Integer EgisonValue
vals) == (IntHash HashMap Integer EgisonValue
vals')                                = HashMap Integer EgisonValue
vals HashMap Integer EgisonValue -> HashMap Integer EgisonValue -> Bool
forall a. Eq a => a -> a -> Bool
== HashMap Integer EgisonValue
vals'
  (CharHash HashMap Char EgisonValue
vals) == (CharHash HashMap Char EgisonValue
vals')                              = HashMap Char EgisonValue
vals HashMap Char EgisonValue -> HashMap Char EgisonValue -> Bool
forall a. Eq a => a -> a -> Bool
== HashMap Char EgisonValue
vals'
  (StrHash HashMap Text EgisonValue
vals) == (StrHash HashMap Text EgisonValue
vals')                                = HashMap Text EgisonValue
vals HashMap Text EgisonValue -> HashMap Text EgisonValue -> Bool
forall a. Eq a => a -> a -> Bool
== HashMap Text EgisonValue
vals'
  -- Temporary: searching a better solution
  (Func (Just Var
name1) Env
_ CallStack
_ IExpr
_) == (Func (Just Var
name2) Env
_ CallStack
_ IExpr
_)           = Var
name1 Var -> Var -> Bool
forall a. Eq a => a -> a -> Bool
== Var
name2
  EgisonValue
_ == EgisonValue
_                                                           = Bool
False

--
-- Egison data and Haskell data
--
class EgisonData a where
  toEgison :: a -> EgisonValue
  fromEgison :: EgisonValue -> EvalM a

instance EgisonData Char where
  toEgison :: Char -> EgisonValue
toEgison = Char -> EgisonValue
Char
  fromEgison :: EgisonValue -> EvalM Char
fromEgison (Char Char
c) = Char -> EvalM Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
c
  fromEgison EgisonValue
val      = (CallStack -> EgisonError) -> EvalM Char
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"char" (EgisonValue -> WHNFData
Value EgisonValue
val))

instance EgisonData Text where
  toEgison :: Text -> EgisonValue
toEgison = Text -> EgisonValue
String
  fromEgison :: EgisonValue -> EvalM Text
fromEgison (String Text
str) = Text -> EvalM Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
str
  fromEgison EgisonValue
val          = (CallStack -> EgisonError) -> EvalM Text
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"string" (EgisonValue -> WHNFData
Value EgisonValue
val))

instance EgisonData Bool where
  toEgison :: Bool -> EgisonValue
toEgison = Bool -> EgisonValue
Bool
  fromEgison :: EgisonValue -> EvalM Bool
fromEgison (Bool Bool
b) = Bool -> EvalM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
b
  fromEgison EgisonValue
val      = (CallStack -> EgisonError) -> EvalM Bool
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"bool" (EgisonValue -> WHNFData
Value EgisonValue
val))

instance EgisonData Integer where
  toEgison :: Integer -> EgisonValue
toEgison Integer
0 = ScalarData -> EgisonValue
ScalarData (PolyExpr -> PolyExpr -> ScalarData
Div ([TermExpr] -> PolyExpr
Plus []) ([TermExpr] -> PolyExpr
Plus [Integer -> Monomial -> TermExpr
Term Integer
1 []]))
  toEgison Integer
i = ScalarData -> EgisonValue
ScalarData (Integer -> Monomial -> ScalarData
SingleTerm Integer
i [])
  fromEgison :: EgisonValue
-> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
fromEgison (ScalarData (Div (Plus []) (Plus [Term Integer
1 []]))) = Integer -> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0
  fromEgison (ScalarData (SingleTerm Integer
x []))                  = Integer -> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
x
  fromEgison EgisonValue
val                                             = (CallStack -> EgisonError)
-> StateT EvalState (ExceptT EgisonError RuntimeM) Integer
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"integer" (EgisonValue -> WHNFData
Value EgisonValue
val))

instance EgisonData Rational where
  toEgison :: Rational -> EgisonValue
toEgison Rational
r = ScalarData -> EgisonValue
ScalarData (ScalarData -> EgisonValue) -> ScalarData -> EgisonValue
forall a b. (a -> b) -> a -> b
$ ScalarData -> ScalarData
mathNormalize' (PolyExpr -> PolyExpr -> ScalarData
Div ([TermExpr] -> PolyExpr
Plus [Integer -> Monomial -> TermExpr
Term (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r) []]) ([TermExpr] -> PolyExpr
Plus [Integer -> Monomial -> TermExpr
Term (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r) []]))
  fromEgison :: EgisonValue -> EvalM Rational
fromEgison (ScalarData (Div (Plus []) PolyExpr
_))                           = Rational -> EvalM Rational
forall (m :: * -> *) a. Monad m => a -> m a
return Rational
0
  fromEgison (ScalarData (Div (Plus [Term Integer
x []]) (Plus [Term Integer
y []]))) = Rational -> EvalM Rational
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
x Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
y)
  fromEgison EgisonValue
val                                                      = (CallStack -> EgisonError) -> EvalM Rational
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"rational" (EgisonValue -> WHNFData
Value EgisonValue
val))

instance EgisonData Double where
  toEgison :: Double -> EgisonValue
toEgison Double
f = Double -> EgisonValue
Float Double
f
  fromEgison :: EgisonValue -> EvalM Double
fromEgison (Float Double
f) = Double -> EvalM Double
forall (m :: * -> *) a. Monad m => a -> m a
return Double
f
  fromEgison EgisonValue
val       = (CallStack -> EgisonError) -> EvalM Double
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"float" (EgisonValue -> WHNFData
Value EgisonValue
val))

instance EgisonData Handle where
  toEgison :: Handle -> EgisonValue
toEgison = Handle -> EgisonValue
Port
  fromEgison :: EgisonValue -> EvalM Handle
fromEgison (Port Handle
h) = Handle -> EvalM Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
h
  fromEgison EgisonValue
val      = (CallStack -> EgisonError) -> EvalM Handle
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"port" (EgisonValue -> WHNFData
Value EgisonValue
val))

instance EgisonData a => EgisonData [a] where
  toEgison :: [a] -> EgisonValue
toEgison [a]
xs = Seq EgisonValue -> EgisonValue
Collection (Seq EgisonValue -> EgisonValue) -> Seq EgisonValue -> EgisonValue
forall a b. (a -> b) -> a -> b
$ [EgisonValue] -> Seq EgisonValue
forall a. [a] -> Seq a
Sq.fromList ((a -> EgisonValue) -> [a] -> [EgisonValue]
forall a b. (a -> b) -> [a] -> [b]
map a -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison [a]
xs)
  fromEgison :: EgisonValue -> EvalM [a]
fromEgison (Collection Seq EgisonValue
seq) = (EgisonValue -> StateT EvalState (ExceptT EgisonError RuntimeM) a)
-> [EgisonValue] -> EvalM [a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM EgisonValue -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison (Seq EgisonValue -> [EgisonValue]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq EgisonValue
seq)
  fromEgison EgisonValue
val              = (CallStack -> EgisonError) -> EvalM [a]
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"collection" (EgisonValue -> WHNFData
Value EgisonValue
val))

instance EgisonData () where
  toEgison :: () -> EgisonValue
toEgison () = [EgisonValue] -> EgisonValue
Tuple []
  fromEgison :: EgisonValue -> EvalM ()
fromEgison (Tuple []) = () -> EvalM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  fromEgison EgisonValue
val        = (CallStack -> EgisonError) -> EvalM ()
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"zero element tuple" (EgisonValue -> WHNFData
Value EgisonValue
val))

instance (EgisonData a, EgisonData b) => EgisonData (a, b) where
  toEgison :: (a, b) -> EgisonValue
toEgison (a
x, b
y) = [EgisonValue] -> EgisonValue
Tuple [a -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison a
x, b -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison b
y]
  fromEgison :: EgisonValue -> EvalM (a, b)
fromEgison (Tuple [EgisonValue
x, EgisonValue
y]) = (a -> b -> (a, b))
-> StateT EvalState (ExceptT EgisonError RuntimeM) a
-> StateT EvalState (ExceptT EgisonError RuntimeM) b
-> EvalM (a, b)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (EgisonValue -> StateT EvalState (ExceptT EgisonError RuntimeM) a
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison EgisonValue
x) (EgisonValue -> StateT EvalState (ExceptT EgisonError RuntimeM) b
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison EgisonValue
y)
  fromEgison EgisonValue
val            = (CallStack -> EgisonError) -> EvalM (a, b)
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"two elements tuple" (EgisonValue -> WHNFData
Value EgisonValue
val))

instance (EgisonData a, EgisonData b, EgisonData c) => EgisonData (a, b, c) where
  toEgison :: (a, b, c) -> EgisonValue
toEgison (a
x, b
y, c
z) = [EgisonValue] -> EgisonValue
Tuple [a -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison a
x, b -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison b
y, c -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison c
z]
  fromEgison :: EgisonValue -> EvalM (a, b, c)
fromEgison (Tuple [EgisonValue
x, EgisonValue
y, EgisonValue
z]) = do
    a
x' <- EgisonValue -> EvalM a
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison EgisonValue
x
    b
y' <- EgisonValue -> EvalM b
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison EgisonValue
y
    c
z' <- EgisonValue -> EvalM c
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison EgisonValue
z
    (a, b, c) -> EvalM (a, b, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x', b
y', c
z')
  fromEgison EgisonValue
val = (CallStack -> EgisonError) -> EvalM (a, b, c)
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"two elements tuple" (EgisonValue -> WHNFData
Value EgisonValue
val))

instance (EgisonData a, EgisonData b, EgisonData c, EgisonData d) => EgisonData (a, b, c, d) where
  toEgison :: (a, b, c, d) -> EgisonValue
toEgison (a
x, b
y, c
z, d
w) = [EgisonValue] -> EgisonValue
Tuple [a -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison a
x, b -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison b
y, c -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison c
z, d -> EgisonValue
forall a. EgisonData a => a -> EgisonValue
toEgison d
w]
  fromEgison :: EgisonValue -> EvalM (a, b, c, d)
fromEgison (Tuple [EgisonValue
x, EgisonValue
y, EgisonValue
z, EgisonValue
w]) = do
    a
x' <- EgisonValue -> EvalM a
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison EgisonValue
x
    b
y' <- EgisonValue -> EvalM b
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison EgisonValue
y
    c
z' <- EgisonValue -> EvalM c
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison EgisonValue
z
    d
w' <- EgisonValue -> EvalM d
forall a. EgisonData a => EgisonValue -> EvalM a
fromEgison EgisonValue
w
    (a, b, c, d) -> EvalM (a, b, c, d)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x', b
y', c
z', d
w')
  fromEgison EgisonValue
val = (CallStack -> EgisonError) -> EvalM (a, b, c, d)
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"two elements tuple" (EgisonValue -> WHNFData
Value EgisonValue
val))

instance EgisonData (IORef EgisonValue) where
  toEgison :: IORef EgisonValue -> EgisonValue
toEgison = IORef EgisonValue -> EgisonValue
RefBox
  fromEgison :: EgisonValue -> EvalM (IORef EgisonValue)
fromEgison (RefBox IORef EgisonValue
ref) = IORef EgisonValue -> EvalM (IORef EgisonValue)
forall (m :: * -> *) a. Monad m => a -> m a
return IORef EgisonValue
ref
  fromEgison EgisonValue
val          = (CallStack -> EgisonError) -> EvalM (IORef EgisonValue)
forall a. (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace (String -> WHNFData -> CallStack -> EgisonError
TypeMismatch String
"ioRef" (EgisonValue -> WHNFData
Value EgisonValue
val))

--
-- Internal Data
--

-- |For memoization
type ObjectRef = IORef Object

data Object
  = Thunk (EvalM WHNFData)
  | WHNF WHNFData

data WHNFData
  = Value EgisonValue
  | IInductiveData String [ObjectRef]
  | ITuple [ObjectRef]
  | ICollection (IORef (Seq Inner))
  | IIntHash (HashMap Integer ObjectRef)
  | ICharHash (HashMap Char ObjectRef)
  | IStrHash (HashMap Text ObjectRef)
  | ITensor (Tensor ObjectRef)

data Inner
  = IElement ObjectRef
  | ISubCollection ObjectRef

instance Show WHNFData where
  show :: WHNFData -> String
show (Value EgisonValue
val)                = EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
val
  show (IInductiveData String
name [ObjectRef]
_)    = String
"<" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ...>"
  show (ITuple [ObjectRef]
_)                 = String
"(...)"
  show (ICollection IORef (Seq Inner)
_)            = String
"[...]"
  show (IIntHash HashMap Integer ObjectRef
_)               = String
"{|...|}"
  show (ICharHash HashMap Char ObjectRef
_)              = String
"{|...|}"
  show (IStrHash HashMap Text ObjectRef
_)               = String
"{|...|}"
  show (ITensor (Tensor [Integer]
ns Vector ObjectRef
xs [Index EgisonValue]
_)) = String
"[|" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Integer] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Integer]
ns) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Vector ObjectRef -> Int
forall a. Vector a -> Int
V.length Vector ObjectRef
xs) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"|]"
  show (ITensor (Scalar ObjectRef
_))       = String
"scalar"

instance Show Object where
  show :: Object -> String
show (Thunk EvalM WHNFData
_)   = String
"#<thunk>"
  show (WHNF WHNFData
whnf) = WHNFData -> String
forall a. Show a => a -> String
show WHNFData
whnf

instance Show ObjectRef where
  show :: ObjectRef -> String
show ObjectRef
_ = String
"#<ref>"

--
-- Environment
--

data Env = Env [HashMap Var ObjectRef] (Maybe (String, [Index (Maybe ScalarData)]))

type Binding = (Var, ObjectRef)

instance {-# OVERLAPPING #-} Show (Index EgisonValue) where
  show :: Index EgisonValue -> String
show (Sup EgisonValue
i) = case EgisonValue
i of
    ScalarData (SingleTerm Integer
1 [(Symbol String
_ String
_ (Index ScalarData
_:[Index ScalarData]
_), Integer
1)]) -> String
"~[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
    EgisonValue
_                                                 -> String
"~" String -> ShowS
forall a. [a] -> [a] -> [a]
++ EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
i
  show (Sub EgisonValue
i) = case EgisonValue
i of
    ScalarData (SingleTerm Integer
1 [(Symbol String
_ String
_ (Index ScalarData
_:[Index ScalarData]
_), Integer
1)]) -> String
"_[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
    EgisonValue
_                                                 -> String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
i
  show (SupSub EgisonValue
i) = String
"~_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
i
  show (User EgisonValue
i) = case EgisonValue
i of
    ScalarData (SingleTerm Integer
1 [(Symbol String
_ String
_ (Index ScalarData
_:[Index ScalarData]
_), Integer
1)]) -> String
"_[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
    EgisonValue
_                                                 -> String
"|" String -> ShowS
forall a. [a] -> [a] -> [a]
++ EgisonValue -> String
forall a. Show a => a -> String
show EgisonValue
i
  show (DF Integer
i Integer
j) = String
"_d" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
j

nullEnv :: Env
nullEnv :: Env
nullEnv = [HashMap Var ObjectRef]
-> Maybe (String, [Index (Maybe ScalarData)]) -> Env
Env [] Maybe (String, [Index (Maybe ScalarData)])
forall a. Maybe a
Nothing

extendEnv :: Env -> [Binding] -> Env
extendEnv :: Env -> [Binding] -> Env
extendEnv (Env [HashMap Var ObjectRef]
env Maybe (String, [Index (Maybe ScalarData)])
idx) [Binding]
bdg = [HashMap Var ObjectRef]
-> Maybe (String, [Index (Maybe ScalarData)]) -> Env
Env ([Binding] -> HashMap Var ObjectRef
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [Binding]
bdg HashMap Var ObjectRef
-> [HashMap Var ObjectRef] -> [HashMap Var ObjectRef]
forall a. a -> [a] -> [a]
: [HashMap Var ObjectRef]
env) Maybe (String, [Index (Maybe ScalarData)])
idx

refVar :: Env -> Var -> Maybe ObjectRef
refVar :: Env -> Var -> Maybe ObjectRef
refVar (Env [HashMap Var ObjectRef]
env Maybe (String, [Index (Maybe ScalarData)])
_) var :: Var
var@(Var String
_ []) = [Maybe ObjectRef] -> Maybe ObjectRef
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe ObjectRef] -> Maybe ObjectRef)
-> [Maybe ObjectRef] -> Maybe ObjectRef
forall a b. (a -> b) -> a -> b
$ (HashMap Var ObjectRef -> Maybe ObjectRef)
-> [HashMap Var ObjectRef] -> [Maybe ObjectRef]
forall a b. (a -> b) -> [a] -> [b]
map (Var -> HashMap Var ObjectRef -> Maybe ObjectRef
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Var
var) [HashMap Var ObjectRef]
env
refVar e :: Env
e@(Env [HashMap Var ObjectRef]
env Maybe (String, [Index (Maybe ScalarData)])
_) var :: Var
var@(Var String
name [Index (Maybe Var)]
is) =
  case [Maybe ObjectRef] -> Maybe ObjectRef
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe ObjectRef] -> Maybe ObjectRef)
-> [Maybe ObjectRef] -> Maybe ObjectRef
forall a b. (a -> b) -> a -> b
$ (HashMap Var ObjectRef -> Maybe ObjectRef)
-> [HashMap Var ObjectRef] -> [Maybe ObjectRef]
forall a b. (a -> b) -> [a] -> [b]
map (Var -> HashMap Var ObjectRef -> Maybe ObjectRef
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Var
var) [HashMap Var ObjectRef]
env of
    Maybe ObjectRef
Nothing -> Env -> Var -> Maybe ObjectRef
refVar Env
e (String -> [Index (Maybe Var)] -> Var
Var String
name ([Index (Maybe Var)] -> [Index (Maybe Var)]
forall a. [a] -> [a]
init [Index (Maybe Var)]
is))
    Just ObjectRef
x  -> ObjectRef -> Maybe ObjectRef
forall a. a -> Maybe a
Just ObjectRef
x

--
-- Errors
--

type CallStack = [Var]

data EgisonError
  = UnboundVariable String CallStack
  | TypeMismatch String WHNFData CallStack
  | ArgumentsNumPrimitive String Int Int CallStack
  | TupleLength Int Int CallStack
  | InconsistentTensorShape CallStack
  | InconsistentTensorIndex CallStack
  | TensorIndexOutOfBounds Integer Integer CallStack
  | NotImplemented String CallStack
  | Assertion String CallStack
  | Parser String
  | EgisonBug String CallStack
  | MatchFailure CallStack
  | PrimitiveMatchFailure CallStack
  | Default String

instance Show EgisonError where
  show :: EgisonError -> String
show (UnboundVariable String
var CallStack
stack) =
    String
"Unbound variable: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
var String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
showTrace CallStack
stack
  show (TypeMismatch String
expected WHNFData
found CallStack
stack) =
    String
"Expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++  String
expected String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", but found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ WHNFData -> String
forall a. Show a => a -> String
show WHNFData
found String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
showTrace CallStack
stack
  show (ArgumentsNumPrimitive String
name Int
expected Int
got CallStack
stack) =
    String
"Wrong number of arguments for a primitive function '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"': expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
expected String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", but got " String -> ShowS
forall a. [a] -> [a] -> [a]
++  Int -> String
forall a. Show a => a -> String
show Int
got String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
showTrace CallStack
stack
  show (TupleLength Int
expected Int
got CallStack
stack) =
    String
"Inconsistent tuple lengths: expected " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
expected String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", but got " String -> ShowS
forall a. [a] -> [a] -> [a]
++  Int -> String
forall a. Show a => a -> String
show Int
got String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
showTrace CallStack
stack
  show (InconsistentTensorShape CallStack
stack) = String
"Inconsistent tensor shape" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
showTrace CallStack
stack
  show (InconsistentTensorIndex CallStack
stack) = String
"Inconsistent tensor index" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
showTrace CallStack
stack
  show (TensorIndexOutOfBounds Integer
m Integer
n CallStack
stack) = String
"Tensor index out of bounds: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
showTrace CallStack
stack
  show (NotImplemented String
message CallStack
stack) = String
"Not implemented: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
message String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
showTrace CallStack
stack
  show (Assertion String
message CallStack
stack) = String
"Assertion failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
message String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
showTrace CallStack
stack
  show (Parser String
err) = String
"Parse error at: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
err
  show (EgisonBug String
message CallStack
stack) = String
"Egison Error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
message String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
showTrace CallStack
stack
  show (MatchFailure CallStack
stack) = String
"Pattern match failed" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
showTrace CallStack
stack
  show (PrimitiveMatchFailure CallStack
stack) = String
"Primitive data pattern match failed" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CallStack -> String
showTrace CallStack
stack
  show (Default String
message) = String
"Error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
message

showTrace :: CallStack -> String
showTrace :: CallStack -> String
showTrace CallStack
stack = String
"\n  stack trace: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Var -> String) -> CallStack -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Var -> String
forall a. Show a => a -> String
show CallStack
stack)

instance Exception EgisonError

--
-- Monads
--

type EvalT m = StateT EvalState (ExceptT EgisonError m)

type EvalM = EvalT RuntimeM

throwErrorWithTrace :: (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace :: (CallStack -> EgisonError) -> EvalM a
throwErrorWithTrace CallStack -> EgisonError
e = EgisonError -> EvalM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EgisonError -> EvalM a)
-> (CallStack -> EgisonError) -> CallStack -> EvalM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> EgisonError
e (CallStack -> EvalM a)
-> StateT EvalState (ExceptT EgisonError RuntimeM) CallStack
-> EvalM a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT EvalState (ExceptT EgisonError RuntimeM) CallStack
forall (m :: * -> *). MonadEval m => m CallStack
getFuncNameStack

instance MonadRuntime EvalM where
  fresh :: EvalM String
fresh = ExceptT EgisonError RuntimeM String -> EvalM String
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT EgisonError RuntimeM String -> EvalM String)
-> ExceptT EgisonError RuntimeM String -> EvalM String
forall a b. (a -> b) -> a -> b
$ RuntimeM String -> ExceptT EgisonError RuntimeM String
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift RuntimeM String
forall (m :: * -> *). MonadRuntime m => m String
fresh

fromEvalT :: EvalM a -> RuntimeM (Either EgisonError a)
fromEvalT :: EvalM a -> RuntimeM (Either EgisonError a)
fromEvalT EvalM a
m = ExceptT EgisonError RuntimeM a -> RuntimeM (Either EgisonError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (EvalM a -> EvalState -> ExceptT EgisonError RuntimeM a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT EvalM a
m EvalState
initialEvalState)

fromEvalM :: EgisonOpts -> EvalM a -> IO (Either EgisonError a)
fromEvalM :: EgisonOpts -> EvalM a -> IO (Either EgisonError a)
fromEvalM EgisonOpts
opts = EgisonOpts
-> RuntimeT IO (Either EgisonError a) -> IO (Either EgisonError a)
forall (m :: * -> *) a.
Monad m =>
EgisonOpts -> RuntimeT m a -> m a
evalRuntimeT EgisonOpts
opts (RuntimeT IO (Either EgisonError a) -> IO (Either EgisonError a))
-> (EvalM a -> RuntimeT IO (Either EgisonError a))
-> EvalM a
-> IO (Either EgisonError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalM a -> RuntimeT IO (Either EgisonError a)
forall a. EvalM a -> RuntimeM (Either EgisonError a)
fromEvalT