{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Swarm.Language.Value (
Value (..),
prettyValue,
valueToTerm,
Env,
emptyEnv,
envTypes,
envReqs,
envVals,
envTydefs,
lookupValue,
addBinding,
addValueBinding,
addTydef,
) where
import Control.Lens hiding (Const)
import Data.Bool (bool)
import Data.List (foldl')
import Data.Map (Map)
import Data.Map qualified as M
import Data.Set qualified as S
import Data.Set.Lens (setOf)
import Data.Text (Text)
import GHC.Generics (Generic)
import Swarm.Language.Context (Ctx)
import Swarm.Language.Context qualified as Ctx
import Swarm.Language.Key (KeyCombo, prettyKeyCombo)
import Swarm.Language.Pretty (prettyText)
import Swarm.Language.Requirements.Type (ReqCtx, Requirements)
import Swarm.Language.Syntax
import Swarm.Language.Syntax.Direction
import Swarm.Language.Typed
import Swarm.Language.Types (Polytype, TCtx, TDCtx, TydefInfo)
data Value where
VUnit :: Value
VInt :: Integer -> Value
VText :: Text -> Value
VDir :: Direction -> Value
VBool :: Bool -> Value
VRobot :: Int -> Value
VInj :: Bool -> Value -> Value
VPair :: Value -> Value -> Value
VClo :: Var -> Term -> Env -> Value
VCApp :: Const -> [Value] -> Value
VBind :: Maybe Var -> Maybe Polytype -> Maybe Requirements -> Term -> Term -> Env -> Value
VDelay :: Term -> Env -> Value
VRef :: Int -> Value
VIndir :: Int -> Value
VRcd :: Map Var Value -> Value
VKey :: KeyCombo -> Value
VRequirements :: Text -> Term -> Env -> Value
VSuspend :: Term -> Env -> Value
VExc :: Value
VBlackhole :: Value
deriving (Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
/= :: Value -> Value -> Bool
Eq, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Value -> ShowS
showsPrec :: Int -> Value -> ShowS
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> ShowS
showList :: [Value] -> ShowS
Show, (forall x. Value -> Rep Value x)
-> (forall x. Rep Value x -> Value) -> Generic Value
forall x. Rep Value x -> Value
forall x. Value -> Rep Value x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Value -> Rep Value x
from :: forall x. Value -> Rep Value x
$cto :: forall x. Rep Value x -> Value
to :: forall x. Rep Value x -> Value
Generic)
type VCtx = Ctx Value
data Env = Env
{ Env -> TCtx
_envTypes :: TCtx
, Env -> ReqCtx
_envReqs :: ReqCtx
, Env -> Ctx Value
_envVals :: VCtx
, Env -> TDCtx
_envTydefs :: TDCtx
}
deriving (Env -> Env -> Bool
(Env -> Env -> Bool) -> (Env -> Env -> Bool) -> Eq Env
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Env -> Env -> Bool
== :: Env -> Env -> Bool
$c/= :: Env -> Env -> Bool
/= :: Env -> Env -> Bool
Eq, Int -> Env -> ShowS
[Env] -> ShowS
Env -> String
(Int -> Env -> ShowS)
-> (Env -> String) -> ([Env] -> ShowS) -> Show Env
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Env -> ShowS
showsPrec :: Int -> Env -> ShowS
$cshow :: Env -> String
show :: Env -> String
$cshowList :: [Env] -> ShowS
showList :: [Env] -> ShowS
Show, (forall x. Env -> Rep Env x)
-> (forall x. Rep Env x -> Env) -> Generic Env
forall x. Rep Env x -> Env
forall x. Env -> Rep Env x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Env -> Rep Env x
from :: forall x. Env -> Rep Env x
$cto :: forall x. Rep Env x -> Env
to :: forall x. Rep Env x -> Env
Generic)
makeLenses ''Env
emptyEnv :: Env
emptyEnv :: Env
emptyEnv = TCtx -> ReqCtx -> Ctx Value -> TDCtx -> Env
Env TCtx
forall t. Ctx t
Ctx.empty ReqCtx
forall t. Ctx t
Ctx.empty Ctx Value
forall t. Ctx t
Ctx.empty TDCtx
forall t. Ctx t
Ctx.empty
lookupValue :: Var -> Env -> Maybe Value
lookupValue :: Var -> Env -> Maybe Value
lookupValue Var
x Env
e = Var -> Ctx Value -> Maybe Value
forall t. Var -> Ctx t -> Maybe t
Ctx.lookup Var
x (Env
e Env -> Getting (Ctx Value) Env (Ctx Value) -> Ctx Value
forall s a. s -> Getting a s a -> a
^. Getting (Ctx Value) Env (Ctx Value)
Lens' Env (Ctx Value)
envVals)
addBinding :: Var -> Typed Value -> Env -> Env
addBinding :: Var -> Typed Value -> Env -> Env
addBinding Var
x Typed Value
v = Index Env -> Lens' Env (Maybe (IxValue Env))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Var
Index Env
x ((Maybe (Typed Value) -> Identity (Maybe (Typed Value)))
-> Env -> Identity Env)
-> Typed Value -> Env -> Env
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Typed Value
v
addValueBinding :: Var -> Value -> Env -> Env
addValueBinding :: Var -> Value -> Env -> Env
addValueBinding Var
x Value
v = (Ctx Value -> Identity (Ctx Value)) -> Env -> Identity Env
Lens' Env (Ctx Value)
envVals ((Ctx Value -> Identity (Ctx Value)) -> Env -> Identity Env)
-> (Ctx Value -> Ctx Value) -> Env -> Env
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Var -> Value -> Ctx Value -> Ctx Value
forall t. Var -> t -> Ctx t -> Ctx t
Ctx.addBinding Var
x Value
v
addTydef :: Var -> TydefInfo -> Env -> Env
addTydef :: Var -> TydefInfo -> Env -> Env
addTydef Var
x TydefInfo
pty = (TDCtx -> Identity TDCtx) -> Env -> Identity Env
Lens' Env TDCtx
envTydefs ((TDCtx -> Identity TDCtx) -> Env -> Identity Env)
-> (TDCtx -> TDCtx) -> Env -> Env
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Var -> TydefInfo -> TDCtx -> TDCtx
forall t. Var -> t -> Ctx t -> Ctx t
Ctx.addBinding Var
x TydefInfo
pty
instance Semigroup Env where
Env TCtx
t1 ReqCtx
r1 Ctx Value
v1 TDCtx
td1 <> :: Env -> Env -> Env
<> Env TCtx
t2 ReqCtx
r2 Ctx Value
v2 TDCtx
td2 = TCtx -> ReqCtx -> Ctx Value -> TDCtx -> Env
Env (TCtx
t1 TCtx -> TCtx -> TCtx
forall a. Semigroup a => a -> a -> a
<> TCtx
t2) (ReqCtx
r1 ReqCtx -> ReqCtx -> ReqCtx
forall a. Semigroup a => a -> a -> a
<> ReqCtx
r2) (Ctx Value
v1 Ctx Value -> Ctx Value -> Ctx Value
forall a. Semigroup a => a -> a -> a
<> Ctx Value
v2) (TDCtx
td1 TDCtx -> TDCtx -> TDCtx
forall a. Semigroup a => a -> a -> a
<> TDCtx
td2)
instance Monoid Env where
mempty :: Env
mempty = TCtx -> ReqCtx -> Ctx Value -> TDCtx -> Env
Env TCtx
forall a. Monoid a => a
mempty ReqCtx
forall a. Monoid a => a
mempty Ctx Value
forall a. Monoid a => a
mempty TDCtx
forall a. Monoid a => a
mempty
instance AsEmpty Env
type instance Index Env = Ctx.Var
type instance IxValue Env = Typed Value
instance Ixed Env
instance At Env where
at :: Index Env -> Lens' Env (Maybe (IxValue Env))
at Index Env
name = (Env -> Maybe (Typed Value))
-> (Env -> Maybe (Typed Value) -> Env)
-> Lens Env Env (Maybe (Typed Value)) (Maybe (Typed Value))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Env -> Maybe (Typed Value)
getter Env -> Maybe (Typed Value) -> Env
setter
where
getter :: Env -> Maybe (Typed Value)
getter Env
ctx =
do
Polytype
typ <- Var -> TCtx -> Maybe Polytype
forall t. Var -> Ctx t -> Maybe t
Ctx.lookup Var
Index Env
name (Env
ctx Env -> Getting TCtx Env TCtx -> TCtx
forall s a. s -> Getting a s a -> a
^. Getting TCtx Env TCtx
Lens' Env TCtx
envTypes)
Value
val <- Var -> Ctx Value -> Maybe Value
forall t. Var -> Ctx t -> Maybe t
Ctx.lookup Var
Index Env
name (Env
ctx Env -> Getting (Ctx Value) Env (Ctx Value) -> Ctx Value
forall s a. s -> Getting a s a -> a
^. Getting (Ctx Value) Env (Ctx Value)
Lens' Env (Ctx Value)
envVals)
Requirements
req <- Var -> ReqCtx -> Maybe Requirements
forall t. Var -> Ctx t -> Maybe t
Ctx.lookup Var
Index Env
name (Env
ctx Env -> Getting ReqCtx Env ReqCtx -> ReqCtx
forall s a. s -> Getting a s a -> a
^. Getting ReqCtx Env ReqCtx
Lens' Env ReqCtx
envReqs)
Typed Value -> Maybe (Typed Value)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Typed Value -> Maybe (Typed Value))
-> Typed Value -> Maybe (Typed Value)
forall a b. (a -> b) -> a -> b
$ Value -> Polytype -> Requirements -> Typed Value
forall v. v -> Polytype -> Requirements -> Typed v
Typed Value
val Polytype
typ Requirements
req
setter :: Env -> Maybe (Typed Value) -> Env
setter Env
ctx Maybe (Typed Value)
Nothing =
Env
ctx
Env -> (Env -> Env) -> Env
forall a b. a -> (a -> b) -> b
& (TCtx -> Identity TCtx) -> Env -> Identity Env
Lens' Env TCtx
envTypes
((TCtx -> Identity TCtx) -> Env -> Identity Env)
-> (TCtx -> TCtx) -> Env -> Env
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Var -> TCtx -> TCtx
forall t. Var -> Ctx t -> Ctx t
Ctx.delete Var
Index Env
name
Env -> (Env -> Env) -> Env
forall a b. a -> (a -> b) -> b
& (Ctx Value -> Identity (Ctx Value)) -> Env -> Identity Env
Lens' Env (Ctx Value)
envVals
((Ctx Value -> Identity (Ctx Value)) -> Env -> Identity Env)
-> (Ctx Value -> Ctx Value) -> Env -> Env
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Var -> Ctx Value -> Ctx Value
forall t. Var -> Ctx t -> Ctx t
Ctx.delete Var
Index Env
name
Env -> (Env -> Env) -> Env
forall a b. a -> (a -> b) -> b
& (ReqCtx -> Identity ReqCtx) -> Env -> Identity Env
Lens' Env ReqCtx
envReqs
((ReqCtx -> Identity ReqCtx) -> Env -> Identity Env)
-> (ReqCtx -> ReqCtx) -> Env -> Env
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Var -> ReqCtx -> ReqCtx
forall t. Var -> Ctx t -> Ctx t
Ctx.delete Var
Index Env
name
setter Env
ctx (Just (Typed Value
val Polytype
typ Requirements
req)) =
Env
ctx
Env -> (Env -> Env) -> Env
forall a b. a -> (a -> b) -> b
& (TCtx -> Identity TCtx) -> Env -> Identity Env
Lens' Env TCtx
envTypes
((TCtx -> Identity TCtx) -> Env -> Identity Env)
-> (TCtx -> TCtx) -> Env -> Env
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Var -> Polytype -> TCtx -> TCtx
forall t. Var -> t -> Ctx t -> Ctx t
Ctx.addBinding Var
Index Env
name Polytype
typ
Env -> (Env -> Env) -> Env
forall a b. a -> (a -> b) -> b
& (Ctx Value -> Identity (Ctx Value)) -> Env -> Identity Env
Lens' Env (Ctx Value)
envVals
((Ctx Value -> Identity (Ctx Value)) -> Env -> Identity Env)
-> (Ctx Value -> Ctx Value) -> Env -> Env
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Var -> Value -> Ctx Value -> Ctx Value
forall t. Var -> t -> Ctx t -> Ctx t
Ctx.addBinding Var
Index Env
name Value
val
Env -> (Env -> Env) -> Env
forall a b. a -> (a -> b) -> b
& (ReqCtx -> Identity ReqCtx) -> Env -> Identity Env
Lens' Env ReqCtx
envReqs
((ReqCtx -> Identity ReqCtx) -> Env -> Identity Env)
-> (ReqCtx -> ReqCtx) -> Env -> Env
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Var -> Requirements -> ReqCtx -> ReqCtx
forall t. Var -> t -> Ctx t -> Ctx t
Ctx.addBinding Var
Index Env
name Requirements
req
prettyValue :: Value -> Text
prettyValue :: Value -> Var
prettyValue = Term -> Var
forall a. PrettyPrec a => a -> Var
prettyText (Term -> Var) -> (Value -> Term) -> Value -> Var
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Term
valueToTerm
valueToTerm :: Value -> Term
valueToTerm :: Value -> Term
valueToTerm = \case
Value
VUnit -> Term
forall ty. Term' ty
TUnit
VInt Integer
n -> Integer -> Term
forall ty. Integer -> Term' ty
TInt Integer
n
VText Var
s -> Var -> Term
forall ty. Var -> Term' ty
TText Var
s
VDir Direction
d -> Direction -> Term
forall ty. Direction -> Term' ty
TDir Direction
d
VBool Bool
b -> Bool -> Term
forall ty. Bool -> Term' ty
TBool Bool
b
VRobot Int
r -> Int -> Term
forall ty. Int -> Term' ty
TRobot Int
r
VInj Bool
s Value
v -> Term -> Term -> Term
TApp (Const -> Term
forall ty. Const -> Term' ty
TConst (Const -> Const -> Bool -> Const
forall a. a -> a -> Bool -> a
bool Const
Inl Const
Inr Bool
s)) (Value -> Term
valueToTerm Value
v)
VPair Value
v1 Value
v2 -> Term -> Term -> Term
TPair (Value -> Term
valueToTerm Value
v1) (Value -> Term
valueToTerm Value
v2)
VClo Var
x Term
t Env
e ->
(Var -> Value -> Term -> Term) -> Term -> Map Var Value -> Term
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey
( \Var
y Value
v -> case Value
v of
VIndir {} -> Term -> Term
forall a. a -> a
id
Value
_ -> LetSyntax
-> Bool
-> Var
-> Maybe Polytype
-> Maybe Requirements
-> Term
-> Term
-> Term
TLet LetSyntax
LSLet Bool
False Var
y Maybe Polytype
forall a. Maybe a
Nothing Maybe Requirements
forall a. Maybe a
Nothing (Value -> Term
valueToTerm Value
v)
)
(Var -> Maybe (Fix TypeF) -> Term -> Term
TLam Var
x Maybe (Fix TypeF)
forall a. Maybe a
Nothing Term
t)
(Map Var Value -> Set Var -> Map Var Value
forall k a. Ord k => Map k a -> Set k -> Map k a
M.restrictKeys (Ctx Value -> Map Var Value
forall t. Ctx t -> Map Var t
Ctx.unCtx (Env
e Env -> Getting (Ctx Value) Env (Ctx Value) -> Ctx Value
forall s a. s -> Getting a s a -> a
^. Getting (Ctx Value) Env (Ctx Value)
Lens' Env (Ctx Value)
envVals)) (Var -> Set Var -> Set Var
forall a. Ord a => a -> Set a -> Set a
S.delete Var
x (Getting (Set Var) (Syntax' ()) Var -> Syntax' () -> Set Var
forall a s. Getting (Set a) s a -> s -> Set a
setOf Getting (Set Var) (Syntax' ()) Var
forall ty (f :: * -> *).
Applicative f =>
(Var -> f Var) -> Syntax' ty -> f (Syntax' ty)
freeVarsV (SrcLoc -> Term -> Comments -> () -> Syntax' ()
forall ty. SrcLoc -> Term' ty -> Comments -> ty -> Syntax' ty
Syntax' SrcLoc
NoLoc Term
t Comments
forall s. AsEmpty s => s
Empty ()))))
VCApp Const
c [Value]
vs -> (Term -> Term -> Term) -> Term -> [Term] -> Term
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Term -> Term -> Term
TApp (Const -> Term
forall ty. Const -> Term' ty
TConst Const
c) ([Term] -> [Term]
forall a. [a] -> [a]
reverse ((Value -> Term) -> [Value] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Term
valueToTerm [Value]
vs))
VBind Maybe Var
mx Maybe Polytype
mty Maybe Requirements
mreq Term
c1 Term
c2 Env
_ -> Maybe Var
-> Maybe Polytype -> Maybe Requirements -> Term -> Term -> Term
TBind Maybe Var
mx Maybe Polytype
mty Maybe Requirements
mreq Term
c1 Term
c2
VDelay Term
t Env
_ -> Term -> Term
TDelay Term
t
VRef Int
n -> Int -> Term
forall ty. Int -> Term' ty
TRef Int
n
VIndir Int
n -> Int -> Term
forall ty. Int -> Term' ty
TRef Int
n
VRcd Map Var Value
m -> Map Var (Maybe Term) -> Term
TRcd (Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> (Value -> Term) -> Value -> Maybe Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Term
valueToTerm (Value -> Maybe Term) -> Map Var Value -> Map Var (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Var Value
m)
VKey KeyCombo
kc -> Term -> Term -> Term
TApp (Const -> Term
forall ty. Const -> Term' ty
TConst Const
Key) (Var -> Term
forall ty. Var -> Term' ty
TText (KeyCombo -> Var
prettyKeyCombo KeyCombo
kc))
VRequirements Var
x Term
t Env
_ -> Var -> Term -> Term
TRequirements Var
x Term
t
VSuspend Term
t Env
_ -> Term -> Term
TSuspend Term
t
Value
VExc -> Const -> Term
forall ty. Const -> Term' ty
TConst Const
Undefined
Value
VBlackhole -> Const -> Term
forall ty. Const -> Term' ty
TConst Const
Undefined