{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
module Swarm.Game.CESK (
Frame (..),
Cont,
WorldUpdate (..),
RobotUpdate (..),
Store,
Addr,
emptyStore,
MemCell (..),
allocate,
lookupStore,
setStore,
CESK (..),
initMachine,
initMachine',
cancel,
resetBlackholes,
finalValue,
TickNumber (..),
addTicks,
) where
import Control.Lens ((^.))
import Control.Lens.Combinators (pattern Empty)
import Data.Aeson (FromJSON, ToJSON)
import Data.Int (Int64)
import Data.IntMap.Strict (IntMap)
import Data.IntMap.Strict qualified as IM
import GHC.Generics (Generic)
import Prettyprinter (Doc, Pretty (..), encloseSep, hsep, (<+>))
import Swarm.Game.Entity (Count, Entity)
import Swarm.Game.Exception
import Swarm.Game.World (WorldUpdate (..))
import Swarm.Language.Context
import Swarm.Language.Module
import Swarm.Language.Pipeline
import Swarm.Language.Pretty
import Swarm.Language.Requirement (ReqCtx)
import Swarm.Language.Syntax
import Swarm.Language.Types
import Swarm.Language.Value as V
import Swarm.Util.WindowedCounter (Offsettable (..))
newtype TickNumber = TickNumber {TickNumber -> Int64
getTickNumber :: Int64}
deriving (TickNumber -> TickNumber -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TickNumber -> TickNumber -> Bool
$c/= :: TickNumber -> TickNumber -> Bool
== :: TickNumber -> TickNumber -> Bool
$c== :: TickNumber -> TickNumber -> Bool
Eq, Eq TickNumber
TickNumber -> TickNumber -> Bool
TickNumber -> TickNumber -> Ordering
TickNumber -> TickNumber -> TickNumber
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TickNumber -> TickNumber -> TickNumber
$cmin :: TickNumber -> TickNumber -> TickNumber
max :: TickNumber -> TickNumber -> TickNumber
$cmax :: TickNumber -> TickNumber -> TickNumber
>= :: TickNumber -> TickNumber -> Bool
$c>= :: TickNumber -> TickNumber -> Bool
> :: TickNumber -> TickNumber -> Bool
$c> :: TickNumber -> TickNumber -> Bool
<= :: TickNumber -> TickNumber -> Bool
$c<= :: TickNumber -> TickNumber -> Bool
< :: TickNumber -> TickNumber -> Bool
$c< :: TickNumber -> TickNumber -> Bool
compare :: TickNumber -> TickNumber -> Ordering
$ccompare :: TickNumber -> TickNumber -> Ordering
Ord, Addr -> TickNumber -> ShowS
[TickNumber] -> ShowS
TickNumber -> String
forall a.
(Addr -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TickNumber] -> ShowS
$cshowList :: [TickNumber] -> ShowS
show :: TickNumber -> String
$cshow :: TickNumber -> String
showsPrec :: Addr -> TickNumber -> ShowS
$cshowsPrec :: Addr -> TickNumber -> ShowS
Show, ReadPrec [TickNumber]
ReadPrec TickNumber
Addr -> ReadS TickNumber
ReadS [TickNumber]
forall a.
(Addr -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TickNumber]
$creadListPrec :: ReadPrec [TickNumber]
readPrec :: ReadPrec TickNumber
$creadPrec :: ReadPrec TickNumber
readList :: ReadS [TickNumber]
$creadList :: ReadS [TickNumber]
readsPrec :: Addr -> ReadS TickNumber
$creadsPrec :: Addr -> ReadS TickNumber
Read, forall x. Rep TickNumber x -> TickNumber
forall x. TickNumber -> Rep TickNumber x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TickNumber x -> TickNumber
$cfrom :: forall x. TickNumber -> Rep TickNumber x
Generic, Value -> Parser [TickNumber]
Value -> Parser TickNumber
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [TickNumber]
$cparseJSONList :: Value -> Parser [TickNumber]
parseJSON :: Value -> Parser TickNumber
$cparseJSON :: Value -> Parser TickNumber
FromJSON, [TickNumber] -> Encoding
[TickNumber] -> Value
TickNumber -> Encoding
TickNumber -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TickNumber] -> Encoding
$ctoEncodingList :: [TickNumber] -> Encoding
toJSONList :: [TickNumber] -> Value
$ctoJSONList :: [TickNumber] -> Value
toEncoding :: TickNumber -> Encoding
$ctoEncoding :: TickNumber -> Encoding
toJSON :: TickNumber -> Value
$ctoJSON :: TickNumber -> Value
ToJSON)
addTicks :: Int -> TickNumber -> TickNumber
addTicks :: Addr -> TickNumber -> TickNumber
addTicks Addr
i (TickNumber Int64
n) = Int64 -> TickNumber
TickNumber forall a b. (a -> b) -> a -> b
$ Int64
n forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Addr
i
instance Offsettable TickNumber where
offsetBy :: Addr -> TickNumber -> TickNumber
offsetBy = Addr -> TickNumber -> TickNumber
addTicks
instance Pretty TickNumber where
pretty :: forall ann. TickNumber -> Doc ann
pretty (TickNumber Int64
i) = forall a ann. Pretty a => a -> Doc ann
pretty Int64
i
data Frame
=
FSnd Term Env
|
FFst Value
|
FArg Term Env
|
FApp Value
|
FLet Var Term Env
|
FTry Value
|
FUnionEnv Env
|
FLoadEnv TCtx ReqCtx
|
FDef Var
|
FExec
|
FBind (Maybe Var) Term Env
|
FDiscardEnv
|
FImmediate Const [WorldUpdate Entity] [RobotUpdate]
|
FUpdate Addr
|
FFinishAtomic
|
FMeetAll Value [Int]
|
FRcd Env [(Var, Value)] Var [(Var, Maybe Term)]
|
FProj Var
deriving (Frame -> Frame -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Frame -> Frame -> Bool
$c/= :: Frame -> Frame -> Bool
== :: Frame -> Frame -> Bool
$c== :: Frame -> Frame -> Bool
Eq, Addr -> Frame -> ShowS
Cont -> ShowS
Frame -> String
forall a.
(Addr -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: Cont -> ShowS
$cshowList :: Cont -> ShowS
show :: Frame -> String
$cshow :: Frame -> String
showsPrec :: Addr -> Frame -> ShowS
$cshowsPrec :: Addr -> Frame -> ShowS
Show, forall x. Rep Frame x -> Frame
forall x. Frame -> Rep Frame x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Frame x -> Frame
$cfrom :: forall x. Frame -> Rep Frame x
Generic, Value -> Parser Cont
Value -> Parser Frame
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser Cont
$cparseJSONList :: Value -> Parser Cont
parseJSON :: Value -> Parser Frame
$cparseJSON :: Value -> Parser Frame
FromJSON, Cont -> Encoding
Cont -> Value
Frame -> Encoding
Frame -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: Cont -> Encoding
$ctoEncodingList :: Cont -> Encoding
toJSONList :: Cont -> Value
$ctoJSONList :: Cont -> Value
toEncoding :: Frame -> Encoding
$ctoEncoding :: Frame -> Encoding
toJSON :: Frame -> Value
$ctoJSON :: Frame -> Value
ToJSON)
type Cont = [Frame]
type Addr = Int
data Store = Store {Store -> Addr
next :: Addr, Store -> IntMap MemCell
mu :: IntMap MemCell}
deriving (Addr -> Store -> ShowS
[Store] -> ShowS
Store -> String
forall a.
(Addr -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Store] -> ShowS
$cshowList :: [Store] -> ShowS
show :: Store -> String
$cshow :: Store -> String
showsPrec :: Addr -> Store -> ShowS
$cshowsPrec :: Addr -> Store -> ShowS
Show, Store -> Store -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Store -> Store -> Bool
$c/= :: Store -> Store -> Bool
== :: Store -> Store -> Bool
$c== :: Store -> Store -> Bool
Eq, forall x. Rep Store x -> Store
forall x. Store -> Rep Store x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Store x -> Store
$cfrom :: forall x. Store -> Rep Store x
Generic, Value -> Parser [Store]
Value -> Parser Store
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Store]
$cparseJSONList :: Value -> Parser [Store]
parseJSON :: Value -> Parser Store
$cparseJSON :: Value -> Parser Store
FromJSON, [Store] -> Encoding
[Store] -> Value
Store -> Encoding
Store -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Store] -> Encoding
$ctoEncodingList :: [Store] -> Encoding
toJSONList :: [Store] -> Value
$ctoJSONList :: [Store] -> Value
toEncoding :: Store -> Encoding
$ctoEncoding :: Store -> Encoding
toJSON :: Store -> Value
$ctoJSON :: Store -> Value
ToJSON)
data MemCell
=
E Term Env
|
Blackhole Term Env
|
V Value
deriving (Addr -> MemCell -> ShowS
[MemCell] -> ShowS
MemCell -> String
forall a.
(Addr -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MemCell] -> ShowS
$cshowList :: [MemCell] -> ShowS
show :: MemCell -> String
$cshow :: MemCell -> String
showsPrec :: Addr -> MemCell -> ShowS
$cshowsPrec :: Addr -> MemCell -> ShowS
Show, MemCell -> MemCell -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MemCell -> MemCell -> Bool
$c/= :: MemCell -> MemCell -> Bool
== :: MemCell -> MemCell -> Bool
$c== :: MemCell -> MemCell -> Bool
Eq, forall x. Rep MemCell x -> MemCell
forall x. MemCell -> Rep MemCell x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MemCell x -> MemCell
$cfrom :: forall x. MemCell -> Rep MemCell x
Generic, Value -> Parser [MemCell]
Value -> Parser MemCell
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MemCell]
$cparseJSONList :: Value -> Parser [MemCell]
parseJSON :: Value -> Parser MemCell
$cparseJSON :: Value -> Parser MemCell
FromJSON, [MemCell] -> Encoding
[MemCell] -> Value
MemCell -> Encoding
MemCell -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MemCell] -> Encoding
$ctoEncodingList :: [MemCell] -> Encoding
toJSONList :: [MemCell] -> Value
$ctoJSONList :: [MemCell] -> Value
toEncoding :: MemCell -> Encoding
$ctoEncoding :: MemCell -> Encoding
toJSON :: MemCell -> Value
$ctoJSON :: MemCell -> Value
ToJSON)
emptyStore :: Store
emptyStore :: Store
emptyStore = Addr -> IntMap MemCell -> Store
Store Addr
0 forall a. IntMap a
IM.empty
allocate :: Env -> Term -> Store -> (Addr, Store)
allocate :: Env -> Term -> Store -> (Addr, Store)
allocate Env
e Term
t (Store Addr
n IntMap MemCell
m) = (Addr
n, Addr -> IntMap MemCell -> Store
Store (Addr
n forall a. Num a => a -> a -> a
+ Addr
1) (forall a. Addr -> a -> IntMap a -> IntMap a
IM.insert Addr
n (Term -> Env -> MemCell
E Term
t Env
e) IntMap MemCell
m))
lookupStore :: Addr -> Store -> Maybe MemCell
lookupStore :: Addr -> Store -> Maybe MemCell
lookupStore Addr
n = forall a. Addr -> IntMap a -> Maybe a
IM.lookup Addr
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. Store -> IntMap MemCell
mu
setStore :: Addr -> MemCell -> Store -> Store
setStore :: Addr -> MemCell -> Store -> Store
setStore Addr
n MemCell
c (Store Addr
nxt IntMap MemCell
m) = Addr -> IntMap MemCell -> Store
Store Addr
nxt (forall a. Addr -> a -> IntMap a -> IntMap a
IM.insert Addr
n MemCell
c IntMap MemCell
m)
data CESK
=
In Term Env Store Cont
|
Out Value Store Cont
|
Up Exn Store Cont
|
Waiting TickNumber CESK
deriving (CESK -> CESK -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CESK -> CESK -> Bool
$c/= :: CESK -> CESK -> Bool
== :: CESK -> CESK -> Bool
$c== :: CESK -> CESK -> Bool
Eq, Addr -> CESK -> ShowS
[CESK] -> ShowS
CESK -> String
forall a.
(Addr -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CESK] -> ShowS
$cshowList :: [CESK] -> ShowS
show :: CESK -> String
$cshow :: CESK -> String
showsPrec :: Addr -> CESK -> ShowS
$cshowsPrec :: Addr -> CESK -> ShowS
Show, forall x. Rep CESK x -> CESK
forall x. CESK -> Rep CESK x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CESK x -> CESK
$cfrom :: forall x. CESK -> Rep CESK x
Generic, Value -> Parser [CESK]
Value -> Parser CESK
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CESK]
$cparseJSONList :: Value -> Parser [CESK]
parseJSON :: Value -> Parser CESK
$cparseJSON :: Value -> Parser CESK
FromJSON, [CESK] -> Encoding
[CESK] -> Value
CESK -> Encoding
CESK -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CESK] -> Encoding
$ctoEncodingList :: [CESK] -> Encoding
toJSONList :: [CESK] -> Value
$ctoJSONList :: [CESK] -> Value
toEncoding :: CESK -> Encoding
$ctoEncoding :: CESK -> Encoding
toJSON :: CESK -> Value
$ctoJSON :: CESK -> Value
ToJSON)
finalValue :: CESK -> Maybe (Value, Store)
{-# INLINE finalValue #-}
finalValue :: CESK -> Maybe (Value, Store)
finalValue (Out Value
v Store
s []) = forall a. a -> Maybe a
Just (Value
v, Store
s)
finalValue CESK
_ = forall a. Maybe a
Nothing
initMachine :: ProcessedTerm -> Env -> Store -> CESK
initMachine :: ProcessedTerm -> Env -> Store -> CESK
initMachine ProcessedTerm
t Env
e Store
s = ProcessedTerm -> Env -> Store -> Cont -> CESK
initMachine' ProcessedTerm
t Env
e Store
s []
initMachine' :: ProcessedTerm -> Env -> Store -> Cont -> CESK
initMachine' :: ProcessedTerm -> Env -> Store -> Cont -> CESK
initMachine' (ProcessedTerm (Module Syntax' (Poly Type)
t' TCtx
ctx) Requirements
_ ReqCtx
reqCtx) Env
e Store
s Cont
k =
case Syntax' (Poly Type)
t' forall s a. s -> Getting a s a -> a
^. forall ty. Lens' (Syntax' ty) ty
sType of
Forall [Var]
_ (TyCmd Type
_) ->
case TCtx
ctx of
TCtx
Empty -> Term -> Env -> Store -> Cont -> CESK
In Term
t Env
e Store
s (Frame
FExec forall a. a -> [a] -> [a]
: Cont
k)
TCtx
_ -> Term -> Env -> Store -> Cont -> CESK
In Term
t Env
e Store
s (Frame
FExec forall a. a -> [a] -> [a]
: TCtx -> ReqCtx -> Frame
FLoadEnv TCtx
ctx ReqCtx
reqCtx forall a. a -> [a] -> [a]
: Cont
k)
Poly Type
_ -> Term -> Env -> Store -> Cont -> CESK
In Term
t Env
e Store
s Cont
k
where
t :: Term
t = forall ty. Syntax' ty -> Term
eraseS Syntax' (Poly Type)
t'
cancel :: CESK -> CESK
cancel :: CESK -> CESK
cancel CESK
cesk = Value -> Store -> Cont -> CESK
Out Value
VUnit Store
s' []
where
s' :: Store
s' = Store -> Store
resetBlackholes forall a b. (a -> b) -> a -> b
$ CESK -> Store
getStore CESK
cesk
getStore :: CESK -> Store
getStore (In Term
_ Env
_ Store
s Cont
_) = Store
s
getStore (Out Value
_ Store
s Cont
_) = Store
s
getStore (Up Exn
_ Store
s Cont
_) = Store
s
getStore (Waiting TickNumber
_ CESK
c) = CESK -> Store
getStore CESK
c
resetBlackholes :: Store -> Store
resetBlackholes :: Store -> Store
resetBlackholes (Store Addr
n IntMap MemCell
m) = Addr -> IntMap MemCell -> Store
Store Addr
n (forall a b. (a -> b) -> IntMap a -> IntMap b
IM.map MemCell -> MemCell
resetBlackhole IntMap MemCell
m)
where
resetBlackhole :: MemCell -> MemCell
resetBlackhole (Blackhole Term
t Env
e) = Term -> Env -> MemCell
E Term
t Env
e
resetBlackhole MemCell
c = MemCell
c
instance PrettyPrec CESK where
prettyPrec :: forall ann. Addr -> CESK -> Doc ann
prettyPrec Addr
_ (In Term
c Env
_ Store
_ Cont
k) = forall ann. Cont -> (Addr, Doc ann) -> Doc ann
prettyCont Cont
k (Addr
11, Doc ann
"▶" forall a. Semigroup a => a -> a -> a
<> forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
c forall a. Semigroup a => a -> a -> a
<> Doc ann
"◀")
prettyPrec Addr
_ (Out Value
v Store
_ Cont
k) = forall ann. Cont -> (Addr, Doc ann) -> Doc ann
prettyCont Cont
k (Addr
11, Doc ann
"◀" forall a. Semigroup a => a -> a -> a
<> forall a ann. PrettyPrec a => a -> Doc ann
ppr (Value -> Term
valueToTerm Value
v) forall a. Semigroup a => a -> a -> a
<> Doc ann
"▶")
prettyPrec Addr
_ (Up Exn
e Store
_ Cont
k) = forall ann. Cont -> (Addr, Doc ann) -> Doc ann
prettyCont Cont
k (Addr
11, Doc ann
"!" forall a. Semigroup a => a -> a -> a
<> (forall a ann. Pretty a => a -> Doc ann
pretty (EntityMap -> Exn -> Var
formatExn forall a. Monoid a => a
mempty Exn
e) forall a. Semigroup a => a -> a -> a
<> Doc ann
"!"))
prettyPrec Addr
_ (Waiting TickNumber
t CESK
cesk) = Doc ann
"🕑" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty TickNumber
t forall a. Semigroup a => a -> a -> a
<> Doc ann
"(" forall a. Semigroup a => a -> a -> a
<> forall a ann. PrettyPrec a => a -> Doc ann
ppr CESK
cesk forall a. Semigroup a => a -> a -> a
<> Doc ann
")"
prettyCont :: Cont -> (Int, Doc ann) -> Doc ann
prettyCont :: forall ann. Cont -> (Addr, Doc ann) -> Doc ann
prettyCont [] (Addr
_, Doc ann
inner) = Doc ann
inner
prettyCont (Frame
f : Cont
k) (Addr, Doc ann)
inner = forall ann. Cont -> (Addr, Doc ann) -> Doc ann
prettyCont Cont
k (forall ann. Frame -> (Addr, Doc ann) -> (Addr, Doc ann)
prettyFrame Frame
f (Addr, Doc ann)
inner)
prettyFrame :: Frame -> (Int, Doc ann) -> (Int, Doc ann)
prettyFrame :: forall ann. Frame -> (Addr, Doc ann) -> (Addr, Doc ann)
prettyFrame (FSnd Term
t Env
_) (Addr
_, Doc ann
inner) = (Addr
11, Doc ann
"(" forall a. Semigroup a => a -> a -> a
<> Doc ann
inner forall a. Semigroup a => a -> a -> a
<> Doc ann
"," forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
t forall a. Semigroup a => a -> a -> a
<> Doc ann
")")
prettyFrame (FFst Value
v) (Addr
_, Doc ann
inner) = (Addr
11, Doc ann
"(" forall a. Semigroup a => a -> a -> a
<> forall a ann. PrettyPrec a => a -> Doc ann
ppr (Value -> Term
valueToTerm Value
v) forall a. Semigroup a => a -> a -> a
<> Doc ann
"," forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
inner forall a. Semigroup a => a -> a -> a
<> Doc ann
")")
prettyFrame (FArg Term
t Env
_) (Addr
p, Doc ann
inner) = (Addr
10, forall ann. Bool -> Doc ann -> Doc ann
pparens (Addr
p forall a. Ord a => a -> a -> Bool
< Addr
10) Doc ann
inner forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => Addr -> a -> Doc ann
prettyPrec Addr
11 Term
t)
prettyFrame (FApp Value
v) (Addr
p, Doc ann
inner) = (Addr
10, forall a ann. PrettyPrec a => Addr -> a -> Doc ann
prettyPrec Addr
10 (Value -> Term
valueToTerm Value
v) forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Bool -> Doc ann -> Doc ann
pparens (Addr
p forall a. Ord a => a -> a -> Bool
< Addr
11) Doc ann
inner)
prettyFrame (FLet Var
x Term
t Env
_) (Addr
_, Doc ann
inner) = (Addr
11, forall ann. [Doc ann] -> Doc ann
hsep [Doc ann
"let", forall a ann. Pretty a => a -> Doc ann
pretty Var
x, Doc ann
"=", Doc ann
inner, Doc ann
"in", forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
t])
prettyFrame (FTry Value
v) (Addr
p, Doc ann
inner) = (Addr
10, Doc ann
"try" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Bool -> Doc ann -> Doc ann
pparens (Addr
p forall a. Ord a => a -> a -> Bool
< Addr
11) Doc ann
inner forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => Addr -> a -> Doc ann
prettyPrec Addr
11 (Value -> Term
valueToTerm Value
v))
prettyFrame (FUnionEnv Env
_) (Addr, Doc ann)
inner = forall ann. Doc ann -> (Addr, Doc ann) -> (Addr, Doc ann)
prettyPrefix Doc ann
"∪·" (Addr, Doc ann)
inner
prettyFrame (FLoadEnv TCtx
_ ReqCtx
_) (Addr, Doc ann)
inner = forall ann. Doc ann -> (Addr, Doc ann) -> (Addr, Doc ann)
prettyPrefix Doc ann
"L·" (Addr, Doc ann)
inner
prettyFrame (FDef Var
x) (Addr
_, Doc ann
inner) = (Addr
11, Doc ann
"def" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. Pretty a => a -> Doc ann
pretty Var
x forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
inner forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"end")
prettyFrame Frame
FExec (Addr, Doc ann)
inner = forall ann. Doc ann -> (Addr, Doc ann) -> (Addr, Doc ann)
prettyPrefix Doc ann
"E·" (Addr, Doc ann)
inner
prettyFrame (FBind Maybe Var
Nothing Term
t Env
_) (Addr
p, Doc ann
inner) = (Addr
0, forall ann. Bool -> Doc ann -> Doc ann
pparens (Addr
p forall a. Ord a => a -> a -> Bool
< Addr
1) Doc ann
inner forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
";" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
t)
prettyFrame (FBind (Just Var
x) Term
t Env
_) (Addr
p, Doc ann
inner) = (Addr
0, forall ann. [Doc ann] -> Doc ann
hsep [forall a ann. Pretty a => a -> Doc ann
pretty Var
x, Doc ann
"<-", forall ann. Bool -> Doc ann -> Doc ann
pparens (Addr
p forall a. Ord a => a -> a -> Bool
< Addr
1) Doc ann
inner, Doc ann
";", forall a ann. PrettyPrec a => a -> Doc ann
ppr Term
t])
prettyFrame Frame
FDiscardEnv (Addr, Doc ann)
inner = forall ann. Doc ann -> (Addr, Doc ann) -> (Addr, Doc ann)
prettyPrefix Doc ann
"D·" (Addr, Doc ann)
inner
prettyFrame (FImmediate Const
c [WorldUpdate Entity]
_worldUpds [RobotUpdate]
_robotUpds) (Addr, Doc ann)
inner = forall ann. Doc ann -> (Addr, Doc ann) -> (Addr, Doc ann)
prettyPrefix (Doc ann
"I[" forall a. Semigroup a => a -> a -> a
<> forall a ann. PrettyPrec a => a -> Doc ann
ppr Const
c forall a. Semigroup a => a -> a -> a
<> Doc ann
"]·") (Addr, Doc ann)
inner
prettyFrame (FUpdate Addr
addr) (Addr, Doc ann)
inner = forall ann. Doc ann -> (Addr, Doc ann) -> (Addr, Doc ann)
prettyPrefix (Doc ann
"S@" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Addr
addr) (Addr, Doc ann)
inner
prettyFrame Frame
FFinishAtomic (Addr, Doc ann)
inner = forall ann. Doc ann -> (Addr, Doc ann) -> (Addr, Doc ann)
prettyPrefix Doc ann
"A·" (Addr, Doc ann)
inner
prettyFrame (FMeetAll Value
_ [Addr]
_) (Addr, Doc ann)
inner = forall ann. Doc ann -> (Addr, Doc ann) -> (Addr, Doc ann)
prettyPrefix Doc ann
"M·" (Addr, Doc ann)
inner
prettyFrame (FRcd Env
_ [(Var, Value)]
done Var
foc [(Var, Maybe Term)]
rest) (Addr
_, Doc ann
inner) = (Addr
11, forall ann. Doc ann -> Doc ann -> Doc ann -> [Doc ann] -> Doc ann
encloseSep Doc ann
"[" Doc ann
"]" Doc ann
", " (forall {ann}. [Doc ann]
pDone forall a. [a] -> [a] -> [a]
++ [Doc ann
pFoc] forall a. [a] -> [a] -> [a]
++ forall {ann}. [Doc ann]
pRest))
where
pDone :: [Doc ann]
pDone = forall a b. (a -> b) -> [a] -> [b]
map (\(Var
x, Value
v) -> forall a ann. Pretty a => a -> Doc ann
pretty Var
x forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr (Value -> Term
valueToTerm Value
v)) (forall a. [a] -> [a]
reverse [(Var, Value)]
done)
pFoc :: Doc ann
pFoc = forall a ann. Pretty a => a -> Doc ann
pretty Var
foc forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
inner
pRest :: [Doc ann]
pRest = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a} {ann}.
(Pretty a, PrettyPrec a) =>
(a, Maybe a) -> Doc ann
pprEq [(Var, Maybe Term)]
rest
pprEq :: (a, Maybe a) -> Doc ann
pprEq (a
x, Maybe a
Nothing) = forall a ann. Pretty a => a -> Doc ann
pretty a
x
pprEq (a
x, Just a
t) = forall a ann. Pretty a => a -> Doc ann
pretty a
x forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
"=" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall a ann. PrettyPrec a => a -> Doc ann
ppr a
t
prettyFrame (FProj Var
x) (Addr
p, Doc ann
inner) = (Addr
11, forall ann. Bool -> Doc ann -> Doc ann
pparens (Addr
p forall a. Ord a => a -> a -> Bool
< Addr
11) Doc ann
inner forall a. Semigroup a => a -> a -> a
<> Doc ann
"." forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Var
x)
prettyPrefix :: Doc ann -> (Int, Doc ann) -> (Int, Doc ann)
prettyPrefix :: forall ann. Doc ann -> (Addr, Doc ann) -> (Addr, Doc ann)
prettyPrefix Doc ann
pre (Addr
p, Doc ann
inner) = (Addr
11, Doc ann
pre forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Bool -> Doc ann -> Doc ann
pparens (Addr
p forall a. Ord a => a -> a -> Bool
< Addr
11) Doc ann
inner)
data RobotUpdate
=
AddEntity Count Entity
|
LearnEntity Entity
deriving (RobotUpdate -> RobotUpdate -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RobotUpdate -> RobotUpdate -> Bool
$c/= :: RobotUpdate -> RobotUpdate -> Bool
== :: RobotUpdate -> RobotUpdate -> Bool
$c== :: RobotUpdate -> RobotUpdate -> Bool
Eq, Eq RobotUpdate
RobotUpdate -> RobotUpdate -> Bool
RobotUpdate -> RobotUpdate -> Ordering
RobotUpdate -> RobotUpdate -> RobotUpdate
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RobotUpdate -> RobotUpdate -> RobotUpdate
$cmin :: RobotUpdate -> RobotUpdate -> RobotUpdate
max :: RobotUpdate -> RobotUpdate -> RobotUpdate
$cmax :: RobotUpdate -> RobotUpdate -> RobotUpdate
>= :: RobotUpdate -> RobotUpdate -> Bool
$c>= :: RobotUpdate -> RobotUpdate -> Bool
> :: RobotUpdate -> RobotUpdate -> Bool
$c> :: RobotUpdate -> RobotUpdate -> Bool
<= :: RobotUpdate -> RobotUpdate -> Bool
$c<= :: RobotUpdate -> RobotUpdate -> Bool
< :: RobotUpdate -> RobotUpdate -> Bool
$c< :: RobotUpdate -> RobotUpdate -> Bool
compare :: RobotUpdate -> RobotUpdate -> Ordering
$ccompare :: RobotUpdate -> RobotUpdate -> Ordering
Ord, Addr -> RobotUpdate -> ShowS
[RobotUpdate] -> ShowS
RobotUpdate -> String
forall a.
(Addr -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RobotUpdate] -> ShowS
$cshowList :: [RobotUpdate] -> ShowS
show :: RobotUpdate -> String
$cshow :: RobotUpdate -> String
showsPrec :: Addr -> RobotUpdate -> ShowS
$cshowsPrec :: Addr -> RobotUpdate -> ShowS
Show, forall x. Rep RobotUpdate x -> RobotUpdate
forall x. RobotUpdate -> Rep RobotUpdate x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RobotUpdate x -> RobotUpdate
$cfrom :: forall x. RobotUpdate -> Rep RobotUpdate x
Generic, Value -> Parser [RobotUpdate]
Value -> Parser RobotUpdate
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RobotUpdate]
$cparseJSONList :: Value -> Parser [RobotUpdate]
parseJSON :: Value -> Parser RobotUpdate
$cparseJSON :: Value -> Parser RobotUpdate
FromJSON, [RobotUpdate] -> Encoding
[RobotUpdate] -> Value
RobotUpdate -> Encoding
RobotUpdate -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RobotUpdate] -> Encoding
$ctoEncodingList :: [RobotUpdate] -> Encoding
toJSONList :: [RobotUpdate] -> Value
$ctoJSONList :: [RobotUpdate] -> Value
toEncoding :: RobotUpdate -> Encoding
$ctoEncoding :: RobotUpdate -> Encoding
toJSON :: RobotUpdate -> Value
$ctoJSON :: RobotUpdate -> Value
ToJSON)