{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- TODO export only needed?
-- module Inferno.Module.Cast (FromValue, ToValue) where
module Inferno.Module.Cast where

import Control.Monad.Except (MonadError (..))
import Control.Monad.Reader (ask)
import Data.Int (Int64)
import qualified Data.Map as Map
import Data.Proxy (Proxy (..))
import qualified Data.Set as Set
import Data.Text (Text, pack, unpack)
import Data.Typeable (Typeable, typeRep)
import Data.Word (Word16, Word32, Word64)
import Foreign.C.Types (CTime (..))
import GHC.TypeLits (KnownSymbol, symbolVal)
import Inferno.Eval.Error (EvalError (CastError, NotFoundInImplicitEnv))
import Inferno.Module.Builtin (enumBoolHash)
import Inferno.Types.Syntax (ExtIdent (..), Lit (..), TList (..))
import Inferno.Types.Type (BaseType (..), InfernoType (..))
import Inferno.Types.Value (ImplEnvM, ImplicitCast (..), Value (..))
import Inferno.Utils.Prettyprinter (renderPretty)
import Prettyprinter (Pretty)

type Either3 a b c = Either a (Either b c)

type Either4 a b c d = Either a (Either3 b c d)

type Either5 a b c d e = Either a (Either4 b c d e)

type Either6 a b c d e f = Either a (Either5 b c d e f)

type Either7 a b c d e f g = Either a (Either6 b c d e f g)

-- | Types that can be converted to script values, allowing IO in the process.
class ToValue c m a where
  toValue :: MonadError EvalError m => a -> m (Value c m)

-- | Class of types that can be converted from script values.
class FromValue c m a where
  fromValue :: MonadError EvalError m => (Value c m) -> m a

-- | Haskell types that can be casted to mask script types.
class Kind0 a where
  toType :: Proxy a -> InfernoType

-- Instances

couldNotCast :: forall c m a. (Pretty c, MonadError EvalError m, Typeable a) => Value c m -> m a
couldNotCast :: forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast Value c m
v =
  forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
    String -> EvalError
CastError forall a b. (a -> b) -> a -> b
$
      String
"Could not cast value " forall a. Semigroup a => a -> a -> a
<> (Text -> String
unpack forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
renderPretty Value c m
v)
        forall a. Semigroup a => a -> a -> a
<> String
" to "
        forall a. Semigroup a => a -> a -> a
<> (forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))

instance ToValue c m (m (Value c m)) where
  toValue :: MonadError EvalError m => m (Value c m) -> m (Value c m)
toValue = forall a. a -> a
id

instance ToValue c m (Value c m) where
  toValue :: MonadError EvalError m => Value c m -> m (Value c m)
toValue = forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromValue c m (Value c m) where
  fromValue :: MonadError EvalError m => Value c m -> m (Value c m)
fromValue = forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance ToValue c m Lit where
  toValue :: MonadError EvalError m => Lit -> m (Value c m)
toValue Lit
l = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Lit
l of
    LInt Int64
i -> forall custom (m :: * -> *). Int64 -> Value custom m
VInt Int64
i
    LDouble Double
x -> forall custom (m :: * -> *). Double -> Value custom m
VDouble Double
x
    LText Text
t -> forall custom (m :: * -> *). Text -> Value custom m
VText Text
t
    LHex Word64
w -> forall custom (m :: * -> *). Word64 -> Value custom m
VWord64 Word64
w

instance ToValue c m Bool where
  toValue :: MonadError EvalError m => Bool -> m (Value c m)
toValue Bool
True = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall custom (m :: * -> *).
VCObjectHash -> Ident -> Value custom m
VEnum VCObjectHash
enumBoolHash Ident
"true"
  toValue Bool
False = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall custom (m :: * -> *).
VCObjectHash -> Ident -> Value custom m
VEnum VCObjectHash
enumBoolHash Ident
"false"

instance Pretty c => FromValue c m Bool where
  fromValue :: MonadError EvalError m => Value c m -> m Bool
fromValue (VEnum VCObjectHash
hash Ident
ident) =
    if VCObjectHash
hash forall a. Eq a => a -> a -> Bool
== VCObjectHash
enumBoolHash
      then
        if Ident
ident forall a. Eq a => a -> a -> Bool
== Ident
"true"
          then forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
          else forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
      else forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast forall a b. (a -> b) -> a -> b
$ (forall custom (m :: * -> *).
VCObjectHash -> Ident -> Value custom m
VEnum VCObjectHash
hash Ident
ident :: Value c m)
  fromValue Value c m
v = forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast Value c m
v

instance ToValue c m Double where
  toValue :: MonadError EvalError m => Double -> m (Value c m)
toValue = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall custom (m :: * -> *). Double -> Value custom m
VDouble

instance Pretty c => FromValue c m Double where
  fromValue :: MonadError EvalError m => Value c m -> m Double
fromValue (VDouble Double
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Double
x
  -- fromValue (VInt x) = pure $ fromIntegral x
  fromValue Value c m
v = forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast Value c m
v

instance ToValue c m Int64 where
  toValue :: MonadError EvalError m => Int64 -> m (Value c m)
toValue = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall custom (m :: * -> *). Int64 -> Value custom m
VInt

instance Pretty c => FromValue c m Int64 where
  fromValue :: MonadError EvalError m => Value c m -> m Int64
fromValue (VInt Int64
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
x
  fromValue Value c m
v = forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast Value c m
v

instance ToValue c m Int where
  toValue :: MonadError EvalError m => Int -> m (Value c m)
toValue = forall c (m :: * -> *) a.
(ToValue c m a, MonadError EvalError m) =>
a -> m (Value c m)
toValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Int64)

instance Pretty c => FromValue c m Int where
  fromValue :: MonadError EvalError m => Value c m -> m Int
fromValue Value c m
v = do
    Int64
i <- forall c (m :: * -> *) a.
(FromValue c m a, MonadError EvalError m) =>
Value c m -> m a
fromValue Value c m
v forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (\EvalError
_ -> forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast Value c m
v)
    if (Int64
i :: Int64) forall a. Ord a => a -> a -> Bool
< forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
minBound :: Int) Bool -> Bool -> Bool
|| Int64
i forall a. Ord a => a -> a -> Bool
> forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Int)
      then forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast Value c m
v
      else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i

instance ToValue c m Integer where
  toValue :: MonadError EvalError m => Integer -> m (Value c m)
toValue = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall custom (m :: * -> *). Int64 -> Value custom m
VInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Integer -> a
fromInteger

instance Pretty c => FromValue c m Integer where
  fromValue :: MonadError EvalError m => Value c m -> m Integer
fromValue (VInt Int64
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
x
  fromValue Value c m
v = forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast Value c m
v

instance ToValue c m Word16 where
  toValue :: MonadError EvalError m => Word16 -> m (Value c m)
toValue = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall custom (m :: * -> *). Word16 -> Value custom m
VWord16

instance Pretty c => FromValue c m Word16 where
  fromValue :: MonadError EvalError m => Value c m -> m Word16
fromValue (VWord16 Word16
w) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Word16
w
  fromValue Value c m
v = forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast Value c m
v

instance ToValue c m Word32 where
  toValue :: MonadError EvalError m => Word32 -> m (Value c m)
toValue = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall custom (m :: * -> *). Word32 -> Value custom m
VWord32

instance Pretty c => FromValue c m Word32 where
  fromValue :: MonadError EvalError m => Value c m -> m Word32
fromValue (VWord32 Word32
w) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Word32
w
  fromValue Value c m
v = forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast Value c m
v

instance ToValue c m Word64 where
  toValue :: MonadError EvalError m => Word64 -> m (Value c m)
toValue = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall custom (m :: * -> *). Word64 -> Value custom m
VWord64

instance Pretty c => FromValue c m Word64 where
  fromValue :: MonadError EvalError m => Value c m -> m Word64
fromValue (VWord64 Word64
w) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
w
  fromValue Value c m
v = forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast Value c m
v

instance ToValue c m () where
  toValue :: MonadError EvalError m => () -> m (Value c m)
toValue ()
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall custom (m :: * -> *). [Value custom m] -> Value custom m
VTuple []

instance Pretty c => FromValue c m () where
  fromValue :: MonadError EvalError m => Value c m -> m ()
fromValue (VTuple []) = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  fromValue Value c m
v = forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast Value c m
v

instance ToValue c m CTime where
  toValue :: MonadError EvalError m => CTime -> m (Value c m)
toValue = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall custom (m :: * -> *). CTime -> Value custom m
VEpochTime

instance Pretty c => FromValue c m CTime where
  fromValue :: MonadError EvalError m => Value c m -> m CTime
fromValue (VEpochTime CTime
t) = forall (f :: * -> *) a. Applicative f => a -> f a
pure CTime
t
  fromValue Value c m
v = forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast Value c m
v

instance ToValue c m Text where
  toValue :: MonadError EvalError m => Text -> m (Value c m)
toValue = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall custom (m :: * -> *). Text -> Value custom m
VText

instance Pretty c => FromValue c m Text where
  fromValue :: MonadError EvalError m => Value c m -> m Text
fromValue (VText Text
t) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t
  fromValue Value c m
v = forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast Value c m
v

instance Kind0 Bool where
  toType :: Proxy Bool -> InfernoType
toType Proxy Bool
_ = BaseType -> InfernoType
TBase forall a b. (a -> b) -> a -> b
$ Text -> Set Ident -> BaseType
TEnum Text
"bool" forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> Set a
Set.fromList [Ident
"true", Ident
"false"]

instance Kind0 Float where
  toType :: Proxy Float -> InfernoType
toType Proxy Float
_ = BaseType -> InfernoType
TBase forall a b. (a -> b) -> a -> b
$ BaseType
TDouble

instance Kind0 Double where
  toType :: Proxy Double -> InfernoType
toType Proxy Double
_ = BaseType -> InfernoType
TBase forall a b. (a -> b) -> a -> b
$ BaseType
TDouble

instance Kind0 Int where
  toType :: Proxy Int -> InfernoType
toType Proxy Int
_ = BaseType -> InfernoType
TBase forall a b. (a -> b) -> a -> b
$ BaseType
TInt

instance Kind0 Int64 where
  toType :: Proxy Int64 -> InfernoType
toType Proxy Int64
_ = BaseType -> InfernoType
TBase forall a b. (a -> b) -> a -> b
$ BaseType
TInt

instance Kind0 Integer where
  toType :: Proxy Integer -> InfernoType
toType Proxy Integer
_ = BaseType -> InfernoType
TBase forall a b. (a -> b) -> a -> b
$ BaseType
TInt

instance Kind0 Word16 where
  toType :: Proxy Word16 -> InfernoType
toType Proxy Word16
_ = BaseType -> InfernoType
TBase forall a b. (a -> b) -> a -> b
$ BaseType
TWord16

instance Kind0 Word32 where
  toType :: Proxy Word32 -> InfernoType
toType Proxy Word32
_ = BaseType -> InfernoType
TBase forall a b. (a -> b) -> a -> b
$ BaseType
TWord32

instance Kind0 Word64 where
  toType :: Proxy Word64 -> InfernoType
toType Proxy Word64
_ = BaseType -> InfernoType
TBase forall a b. (a -> b) -> a -> b
$ BaseType
TWord64

instance Kind0 () where
  toType :: Proxy () -> InfernoType
toType Proxy ()
_ = TList InfernoType -> InfernoType
TTuple forall a. TList a
TNil

instance Kind0 CTime where
  toType :: Proxy CTime -> InfernoType
toType Proxy CTime
_ = BaseType -> InfernoType
TBase forall a b. (a -> b) -> a -> b
$ BaseType
TTime

instance Kind0 Text where
  toType :: Proxy Text -> InfernoType
toType Proxy Text
_ = BaseType -> InfernoType
TBase forall a b. (a -> b) -> a -> b
$ BaseType
TText

instance (Kind0 a, Kind0 b) => Kind0 (a -> b) where
  toType :: Proxy (a -> b) -> InfernoType
toType Proxy (a -> b)
_ = InfernoType -> InfernoType -> InfernoType
TArr (forall a. Kind0 a => Proxy a -> InfernoType
toType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)) (forall a. Kind0 a => Proxy a -> InfernoType
toType (forall {k} (t :: k). Proxy t
Proxy :: Proxy b))

instance (Kind0 a) => Kind0 [a] where
  toType :: Proxy [a] -> InfernoType
toType Proxy [a]
_ = InfernoType -> InfernoType
TArray (forall a. Kind0 a => Proxy a -> InfernoType
toType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))

instance (FromValue c m a, ToValue c m b) => ToValue c m (a -> b) where
  toValue :: MonadError EvalError m => (a -> b) -> m (Value c m)
toValue a -> b
f = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall custom (m :: * -> *).
(Value custom m -> m (Value custom m)) -> Value custom m
VFun forall a b. (a -> b) -> a -> b
$ \Value c m
v -> do
      a
x <- forall c (m :: * -> *) a.
(FromValue c m a, MonadError EvalError m) =>
Value c m -> m a
fromValue Value c m
v
      forall c (m :: * -> *) a.
(ToValue c m a, MonadError EvalError m) =>
a -> m (Value c m)
toValue forall a b. (a -> b) -> a -> b
$ a -> b
f a
x

instance (Monad m, FromValue c (ImplEnvM m c) a1, FromValue c (ImplEnvM m c) a2, ToValue c (ImplEnvM m c) a3, KnownSymbol lbl) => ToValue c (ImplEnvM m c) (ImplicitCast lbl a1 a2 a3) where
  toValue :: MonadError EvalError (ImplEnvM m c) =>
ImplicitCast lbl a1 a2 a3 -> ImplEnvM m c (Value c (ImplEnvM m c))
toValue (ImplicitCast a1 -> a2 -> a3
f) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall custom (m :: * -> *).
(Value custom m -> m (Value custom m)) -> Value custom m
VFun forall a b. (a -> b) -> a -> b
$ \Value c (ImplEnvM m c)
b' -> do
      Map ExtIdent (Value c (ImplEnvM m c))
impl <- forall r (m :: * -> *). MonadReader r m => m r
ask
      let i :: ExtIdent
i = Either Int Text -> ExtIdent
ExtIdent forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy lbl)
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ExtIdent
i Map ExtIdent (Value c (ImplEnvM m c))
impl of
        Just Value c (ImplEnvM m c)
v -> do
          a1
x <- forall c (m :: * -> *) a.
(FromValue c m a, MonadError EvalError m) =>
Value c m -> m a
fromValue Value c (ImplEnvM m c)
v
          a2
b <- forall c (m :: * -> *) a.
(FromValue c m a, MonadError EvalError m) =>
Value c m -> m a
fromValue Value c (ImplEnvM m c)
b'
          forall c (m :: * -> *) a.
(ToValue c m a, MonadError EvalError m) =>
a -> m (Value c m)
toValue forall a b. (a -> b) -> a -> b
$ a1 -> a2 -> a3
f a1
x a2
b
        Maybe (Value c (ImplEnvM m c))
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ ExtIdent -> EvalError
NotFoundInImplicitEnv ExtIdent
i

-- | In this instance, the 'IO' in the type is ignored.
instance Kind0 a => Kind0 (IO a) where
  toType :: Proxy (IO a) -> InfernoType
toType Proxy (IO a)
_ = forall a. Kind0 a => Proxy a -> InfernoType
toType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

instance ToValue c m a => ToValue c m (Maybe a) where
  toValue :: MonadError EvalError m => Maybe a -> m (Value c m)
toValue (Just a
x) = forall custom (m :: * -> *). Value custom m -> Value custom m
VOne forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c (m :: * -> *) a.
(ToValue c m a, MonadError EvalError m) =>
a -> m (Value c m)
toValue a
x
  toValue Maybe a
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall custom (m :: * -> *). Value custom m
VEmpty

instance (Typeable a, FromValue c m a, Pretty c) => FromValue c m (Maybe a) where
  fromValue :: MonadError EvalError m => Value c m -> m (Maybe a)
fromValue Value c m
VEmpty = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  fromValue (VOne Value c m
v) = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c (m :: * -> *) a.
(FromValue c m a, MonadError EvalError m) =>
Value c m -> m a
fromValue Value c m
v
  fromValue Value c m
v = forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast Value c m
v

instance Kind0 a => Kind0 (Maybe a) where
  toType :: Proxy (Maybe a) -> InfernoType
toType Proxy (Maybe a)
_ = InfernoType -> InfernoType
TOptional (forall a. Kind0 a => Proxy a -> InfernoType
toType (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))

instance (ToValue c m a, ToValue c m b) => ToValue c m (Either a b) where
  toValue :: MonadError EvalError m => Either a b -> m (Value c m)
toValue (Left a
x) = forall c (m :: * -> *) a.
(ToValue c m a, MonadError EvalError m) =>
a -> m (Value c m)
toValue a
x
  toValue (Right b
x) = forall c (m :: * -> *) a.
(ToValue c m a, MonadError EvalError m) =>
a -> m (Value c m)
toValue b
x

instance ToValue c m a => ToValue c m [a] where
  toValue :: MonadError EvalError m => [a] -> m (Value c m)
toValue [a]
xs = forall custom (m :: * -> *). [Value custom m] -> Value custom m
VArray forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall c (m :: * -> *) a.
(ToValue c m a, MonadError EvalError m) =>
a -> m (Value c m)
toValue [a]
xs)

instance (Typeable a, FromValue c m a, Pretty c) => FromValue c m [a] where
  fromValue :: MonadError EvalError m => Value c m -> m [a]
fromValue (VArray [Value c m]
vs) = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall c (m :: * -> *) a.
(FromValue c m a, MonadError EvalError m) =>
Value c m -> m a
fromValue [Value c m]
vs
  fromValue Value c m
v = forall c (m :: * -> *) a.
(Pretty c, MonadError EvalError m, Typeable a) =>
Value c m -> m a
couldNotCast Value c m
v

instance (FromValue c m a, FromValue c m b) => FromValue c m (Either a b) where
  fromValue :: MonadError EvalError m => Value c m -> m (Either a b)
fromValue Value c m
v = (forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c (m :: * -> *) a.
(FromValue c m a, MonadError EvalError m) =>
Value c m -> m a
fromValue Value c m
v) forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (\EvalError
_ -> forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c (m :: * -> *) a.
(FromValue c m a, MonadError EvalError m) =>
Value c m -> m a
fromValue Value c m
v)

instance Kind0 (Either a b) where
  toType :: Proxy (Either a b) -> InfernoType
toType Proxy (Either a b)
_ = forall a. HasCallStack => String -> a
error String
"Definitions with Either must have explicit type signature"

-- instance ToValue IO a => ToValue IO (IO a) where
--   toValue io = io >>= toValue

-- instance FromValue m a => FromValue m (IO a) where
--   fromValue = fmap pure . fromValue

-- instance FromValue m (EitherN '[]) where
--   fromValue v = undefined

-- instance (FromValue m a, FromValue m (EitherN as)) => FromValue m (EitherN (a ': as)) where
--   fromValue v = (Here <$> fromValue v) `catchError` (\_ -> Next <$> fromValue v)

-- instance ToValue m (EitherN '[]) where
--   toValue = undefined

-- instance (ToValue m a, ToValue m (EitherN as)) => ToValue m (EitherN (a ': as)) where
--   toValue (Here  x) = toValue x
--   toValue (Next x) = toValue x

-- serializeToDouble :: MonadError EvalError m => Env -> Value m' -> m Double
-- serializeToDouble TypeEnv{..} = \case
--   VInt i -> return $ fromIntegral i
--   VDouble d -> return d
--   VEnum "true" -> return 1.0
--   VEnum "false" -> return 0.0
--   VEnum e -> case Map.lookup e enums of
--     Just (EnumMeta _ _ cs _) -> case fromIntegral <$> elemIndex e cs of
--       Just d -> return d
--       Nothing -> throwError $ RuntimeError $ "Malformed environment! Could not find enum constructor in the list"
--     Just _ -> throwError $ RuntimeError $ "Malformed environment! Was expecting enum metadata"
--     Nothing -> throwError $ CastError $ "Enum #" <> Text.unpack e <> " could not be found in the environment."
--   VWord16 w -> return $ fromIntegral w
--   VWord32 w -> return $ fromIntegral w
--   VWord64 w -> return $ fromIntegral w

-- -- deserializeFromDouble :: MonadError EvalError m => Env -> Double -> InfernoType -> m (Value m')
-- -- deserializeFromDouble env d = \case
-- --   TBase TInt -> return $ VInt $