{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}

module Inferno.Types.Value where

import Control.Monad.Except (MonadError)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (MonadReader, ReaderT (..))
import Data.Int (Int64)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Word (Word16, Word32, Word64)
import GHC.TypeLits (Symbol)
import Inferno.Types.Syntax (ExtIdent, Ident (..), InfernoType)
import Inferno.Types.VersionControl (VCObjectHash)
import Numeric (showHex)
import Prettyprinter
  ( Pretty (pretty),
    align,
    comma,
    encloseSep,
    lbracket,
    rbracket,
    tupled,
    (<+>),
  )
import System.Posix.Types (EpochTime)

data Value custom m
  = VInt Int64
  | VDouble Double
  | VWord16 Word16
  | VWord32 Word32
  | VWord64 Word64
  | VEpochTime EpochTime
  | VText Text
  | VEnum VCObjectHash Ident
  | VArray [Value custom m]
  | VTuple [Value custom m]
  | VOne (Value custom m)
  | VEmpty
  | VFun (Value custom m -> m (Value custom m))
  | VTypeRep InfernoType
  | VCustom custom

instance Eq c => Eq (Value c m) where
  (VInt Int64
i1) == :: Value c m -> Value c m -> Bool
== (VInt Int64
i2) = Int64
i1 forall a. Eq a => a -> a -> Bool
== Int64
i2
  (VDouble Double
v1) == (VDouble Double
v2) = Double
v1 forall a. Eq a => a -> a -> Bool
== Double
v2
  (VWord16 Word16
w1) == (VWord16 Word16
w2) = Word16
w1 forall a. Eq a => a -> a -> Bool
== Word16
w2
  (VWord32 Word32
w1) == (VWord32 Word32
w2) = Word32
w1 forall a. Eq a => a -> a -> Bool
== Word32
w2
  (VWord64 Word64
w1) == (VWord64 Word64
w2) = Word64
w1 forall a. Eq a => a -> a -> Bool
== Word64
w2
  (VEpochTime EpochTime
t1) == (VEpochTime EpochTime
t2) = EpochTime
t1 forall a. Eq a => a -> a -> Bool
== EpochTime
t2
  (VText Text
t1) == (VText Text
t2) = Text
t1 forall a. Eq a => a -> a -> Bool
== Text
t2
  (VEnum VCObjectHash
h1 Ident
e1) == (VEnum VCObjectHash
h2 Ident
e2) = VCObjectHash
h1 forall a. Eq a => a -> a -> Bool
== VCObjectHash
h2 Bool -> Bool -> Bool
&& Ident
e1 forall a. Eq a => a -> a -> Bool
== Ident
e2
  (VOne Value c m
v1) == (VOne Value c m
v2) = Value c m
v1 forall a. Eq a => a -> a -> Bool
== Value c m
v2
  Value c m
VEmpty == Value c m
VEmpty = Bool
True
  (VArray [Value c m]
a1) == (VArray [Value c m]
a2) = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value c m]
a1 forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value c m]
a2 Bool -> Bool -> Bool
&& (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bool -> Bool -> Bool
(&&) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(==))) Bool
True forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Value c m]
a1 [Value c m]
a2)
  (VTuple [Value c m]
a1) == (VTuple [Value c m]
a2) = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value c m]
a1 forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value c m]
a2 Bool -> Bool -> Bool
&& (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bool -> Bool -> Bool
(&&) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Eq a => a -> a -> Bool
(==))) Bool
True forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Value c m]
a1 [Value c m]
a2)
  (VTypeRep InfernoType
t1) == (VTypeRep InfernoType
t2) = InfernoType
t1 forall a. Eq a => a -> a -> Bool
== InfernoType
t2
  (VCustom c
c1) == (VCustom c
c2) = c
c1 forall a. Eq a => a -> a -> Bool
== c
c2
  Value c m
_ == Value c m
_ = Bool
False

instance Pretty c => Pretty (Value c m) where
  pretty :: forall ann. Value c m -> Doc ann
pretty = \case
    VInt Int64
n -> forall a ann. Pretty a => a -> Doc ann
pretty Int64
n
    VDouble Double
n -> forall a ann. Pretty a => a -> Doc ann
pretty Double
n
    VWord16 Word16
w -> Doc ann
"0x" forall a. Semigroup a => a -> a -> a
<> (forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall a. (Integral a, Show a) => a -> ShowS
showHex Word16
w String
"")
    VWord32 Word32
w -> Doc ann
"0x" forall a. Semigroup a => a -> a -> a
<> (forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall a. (Integral a, Show a) => a -> ShowS
showHex Word32
w String
"")
    VWord64 Word64
w -> Doc ann
"0x" forall a. Semigroup a => a -> a -> a
<> (forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall a. (Integral a, Show a) => a -> ShowS
showHex Word64
w String
"")
    VText Text
t -> forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Text
t
    VEnum VCObjectHash
_ (Ident Text
s) -> Doc ann
"#" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Text
s
    VArray [Value c m]
vs -> forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep forall ann. Doc ann
lbracket forall ann. Doc ann
rbracket forall ann. Doc ann
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [Value c m]
vs
    VTuple [Value c m]
vs -> forall ann. [Doc ann] -> Doc ann
tupled forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a ann. Pretty a => a -> Doc ann
pretty [Value c m]
vs
    VOne Value c m
v -> Doc ann
"Some" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
align (forall a ann. Pretty a => a -> Doc ann
pretty Value c m
v)
    Value c m
VEmpty -> Doc ann
"None"
    VFun {} -> Doc ann
"<<function>>"
    VEpochTime EpochTime
t -> forall a ann. Pretty a => a -> Doc ann
pretty forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show EpochTime
t forall a. Semigroup a => a -> a -> a
<> String
"s"
    VTypeRep InfernoType
t -> Doc ann
"@" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty InfernoType
t
    VCustom c
c -> forall a ann. Pretty a => a -> Doc ann
pretty c
c

newtype ImplEnvM m c a = ImplEnvM {forall (m :: * -> *) c a.
ImplEnvM m c a
-> ReaderT (Map ExtIdent (Value c (ImplEnvM m c))) m a
unImplEnvM :: ReaderT (Map.Map ExtIdent (Value c (ImplEnvM m c))) m a}
  deriving (forall a. a -> ImplEnvM m c a
forall a b. ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c a
forall a b. ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c b
forall a b.
ImplEnvM m c (a -> b) -> ImplEnvM m c a -> ImplEnvM m c b
forall a b c.
(a -> b -> c) -> ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c 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
forall {m :: * -> *} {c}. Applicative m => Functor (ImplEnvM m c)
forall (m :: * -> *) c a. Applicative m => a -> ImplEnvM m c a
forall (m :: * -> *) c a b.
Applicative m =>
ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c a
forall (m :: * -> *) c a b.
Applicative m =>
ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c b
forall (m :: * -> *) c a b.
Applicative m =>
ImplEnvM m c (a -> b) -> ImplEnvM m c a -> ImplEnvM m c b
forall (m :: * -> *) c a b c.
Applicative m =>
(a -> b -> c) -> ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c c
<* :: forall a b. ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c a
$c<* :: forall (m :: * -> *) c a b.
Applicative m =>
ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c a
*> :: forall a b. ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c b
$c*> :: forall (m :: * -> *) c a b.
Applicative m =>
ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c b
liftA2 :: forall a b c.
(a -> b -> c) -> ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c c
$cliftA2 :: forall (m :: * -> *) c a b c.
Applicative m =>
(a -> b -> c) -> ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c c
<*> :: forall a b.
ImplEnvM m c (a -> b) -> ImplEnvM m c a -> ImplEnvM m c b
$c<*> :: forall (m :: * -> *) c a b.
Applicative m =>
ImplEnvM m c (a -> b) -> ImplEnvM m c a -> ImplEnvM m c b
pure :: forall a. a -> ImplEnvM m c a
$cpure :: forall (m :: * -> *) c a. Applicative m => a -> ImplEnvM m c a
Applicative, forall a b. a -> ImplEnvM m c b -> ImplEnvM m c a
forall a b. (a -> b) -> ImplEnvM m c a -> ImplEnvM m c b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) c a b.
Functor m =>
a -> ImplEnvM m c b -> ImplEnvM m c a
forall (m :: * -> *) c a b.
Functor m =>
(a -> b) -> ImplEnvM m c a -> ImplEnvM m c b
<$ :: forall a b. a -> ImplEnvM m c b -> ImplEnvM m c a
$c<$ :: forall (m :: * -> *) c a b.
Functor m =>
a -> ImplEnvM m c b -> ImplEnvM m c a
fmap :: forall a b. (a -> b) -> ImplEnvM m c a -> ImplEnvM m c b
$cfmap :: forall (m :: * -> *) c a b.
Functor m =>
(a -> b) -> ImplEnvM m c a -> ImplEnvM m c b
Functor, forall a. a -> ImplEnvM m c a
forall a b. ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c b
forall a b.
ImplEnvM m c a -> (a -> ImplEnvM m c b) -> ImplEnvM m c 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
forall {m :: * -> *} {c}. Monad m => Applicative (ImplEnvM m c)
forall (m :: * -> *) c a. Monad m => a -> ImplEnvM m c a
forall (m :: * -> *) c a b.
Monad m =>
ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c b
forall (m :: * -> *) c a b.
Monad m =>
ImplEnvM m c a -> (a -> ImplEnvM m c b) -> ImplEnvM m c b
return :: forall a. a -> ImplEnvM m c a
$creturn :: forall (m :: * -> *) c a. Monad m => a -> ImplEnvM m c a
>> :: forall a b. ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c b
$c>> :: forall (m :: * -> *) c a b.
Monad m =>
ImplEnvM m c a -> ImplEnvM m c b -> ImplEnvM m c b
>>= :: forall a b.
ImplEnvM m c a -> (a -> ImplEnvM m c b) -> ImplEnvM m c b
$c>>= :: forall (m :: * -> *) c a b.
Monad m =>
ImplEnvM m c a -> (a -> ImplEnvM m c b) -> ImplEnvM m c b
Monad, MonadReader (Map.Map ExtIdent (Value c (ImplEnvM m c))), MonadError e, forall a. (a -> ImplEnvM m c a) -> ImplEnvM m c a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
forall {m :: * -> *} {c}. MonadFix m => Monad (ImplEnvM m c)
forall (m :: * -> *) c a.
MonadFix m =>
(a -> ImplEnvM m c a) -> ImplEnvM m c a
mfix :: forall a. (a -> ImplEnvM m c a) -> ImplEnvM m c a
$cmfix :: forall (m :: * -> *) c a.
MonadFix m =>
(a -> ImplEnvM m c a) -> ImplEnvM m c a
MonadFix, forall a. IO a -> ImplEnvM m c a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *} {c}. MonadIO m => Monad (ImplEnvM m c)
forall (m :: * -> *) c a. MonadIO m => IO a -> ImplEnvM m c a
liftIO :: forall a. IO a -> ImplEnvM m c a
$cliftIO :: forall (m :: * -> *) c a. MonadIO m => IO a -> ImplEnvM m c a
MonadIO)

runImplEnvM :: Map.Map ExtIdent (Value c (ImplEnvM m c)) -> ImplEnvM m c a -> m a
runImplEnvM :: forall c (m :: * -> *) a.
Map ExtIdent (Value c (ImplEnvM m c)) -> ImplEnvM m c a -> m a
runImplEnvM Map ExtIdent (Value c (ImplEnvM m c))
env = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Map ExtIdent (Value c (ImplEnvM m c))
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) c a.
ImplEnvM m c a
-> ReaderT (Map ExtIdent (Value c (ImplEnvM m c))) m a
unImplEnvM

newtype ImplicitCast (lbl :: Symbol) a b c = ImplicitCast (a -> b -> c)