carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-17 16:38:14 +03:00
Code Issues Projects Releases Wiki Activity

feat: Evaluate symbols for statics in REPL (#1090)

Browse Source 
* feat: evaluate defs and defns in repl

* fix: better handling of static symbol evaluation

* refactor: include feedback by @scolsen (thanks)

* refactor: incorporate feedback by @eriksvedang into resolver code

* refactor: rename shouldResolve to resolver
This commit is contained in:
Veit Heller 2020-12-22 15:53:55 +01:00 committed by GitHub
parent 3ecf99fb5f
commit e396863719
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
2 changed files with 66 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

110
src/Eval.hs
View File

@ -37,13 +37,17 @@ data LookupPreference
= PreferDynamic
| PreferGlobal
data Resolver
= ResolveGlobal
| ResolveLocal
-- Prefer dynamic bindings
evalDynamic :: Context -> XObj -> IO (Context, Either EvalError XObj)
evalDynamic ctx xobj = eval ctx xobj PreferDynamic
evalDynamic :: Resolver -> Context -> XObj -> IO (Context, Either EvalError XObj)
evalDynamic resolver ctx xobj = eval ctx xobj PreferDynamic resolver
-- Prefer global bindings
evalStatic :: Context -> XObj -> IO (Context, Either EvalError XObj)
evalStatic ctx xobj = eval ctx xobj PreferGlobal
evalStatic :: Resolver -> Context -> XObj -> IO (Context, Either EvalError XObj)
evalStatic resolver ctx xobj = eval ctx xobj PreferGlobal resolver
-- | Dynamic (REPL) evaluation of XObj:s (s-expressions)
-- Note: You might find a bunch of code of the following form both here and in
@ -59,23 +63,31 @@ evalStatic ctx xobj = eval ctx xobj PreferGlobal
-- it gets real weird with laziness. (Note to the note: this code is mostly a
-- remnant of us using StateT, and might not be necessary anymore since we
-- switched to more explicit state-passing.)
eval :: Context -> XObj -> LookupPreference -> IO (Context, Either EvalError XObj)
eval ctx xobj@(XObj o info ty) preference =
eval :: Context -> XObj -> LookupPreference -> Resolver -> IO (Context, Either EvalError XObj)
eval ctx xobj@(XObj o info ty) preference resolver =
case o of
Lst body -> eval' body
Sym spath@(SymPath p n) _ ->
pure $
fromMaybe
(evalError ctx ("Can't find symbol '" ++ show n ++ "'") info) -- all else failed, error.
-- Certain contexts prefer looking up bindings in the dynamic environment (e.g. defdyanmic) while others
-- prefer the static global environment.
( ( case preference of
case resolver of
ResolveGlobal -> unwrapLookup (tryAllLookups >>= checkStatic)
ResolveLocal -> unwrapLookup tryAllLookups
where
checkStatic v@(_, Right (XObj (Lst ((XObj obj _ _) : _)) _ _)) =
if isResolvableStaticObj obj
then pure (ctx, Left (HasStaticCall xobj info))
else pure v
checkStatic v = pure v
unwrapLookup v =
fromMaybe
(evalError ctx ("Can't find symbol '" ++ show n ++ "'") info) -- all else failed, error.
v
tryAllLookups =
( case preference of
PreferDynamic -> tryDynamicLookup
PreferGlobal -> (tryLookup spath <|> tryDynamicLookup)
)
<|> (if null p then tryInternalLookup spath else tryLookup spath)
)
where
<|> (if null p then tryInternalLookup spath else tryLookup spath)
tryDynamicLookup =
( lookupBinder (SymPath ("Dynamic" : p) n) (contextGlobalEnv ctx)
>>= \(Binder _ found) -> pure (ctx, Right (resolveDef found))
@ -126,11 +138,11 @@ eval ctx xobj@(XObj o info ty) preference =
eval' form =
case form of
[XObj If _ _, mcond, mtrue, mfalse] -> do
(newCtx, evd) <- eval ctx mcond preference
(newCtx, evd) <- eval ctx mcond preference ResolveLocal
case evd of
Right cond ->
case xobjObj cond of
Bol b -> eval newCtx (if b then mtrue else mfalse) preference
Bol b -> eval newCtx (if b then mtrue else mfalse) preference ResolveLocal
_ ->
pure
( evalError
@ -212,7 +224,7 @@ eval ctx xobj@(XObj o info ty) preference =
)
[the@(XObj The _ _), t, value] ->
do
(newCtx, evaledValue) <- expandAll evalDynamic ctx value -- TODO: Why expand all here?
(newCtx, evaledValue) <- expandAll (evalDynamic ResolveLocal) ctx value -- TODO: Why expand all here?
pure
( newCtx,
do
@ -256,7 +268,7 @@ eval ctx xobj@(XObj o info ty) preference =
case eitherCtx of
Left err -> pure (ctx, Left err)
Right newCtx -> do
(finalCtx, evaledBody) <- eval newCtx body preference
(finalCtx, evaledBody) <- eval newCtx body preference ResolveLocal
let Just e = contextInternalEnv finalCtx
pure
( finalCtx {contextInternalEnv = envParent e},
@ -272,7 +284,7 @@ eval ctx xobj@(XObj o info ty) preference =
\case
err@(Left _) -> pure err
Right ctx' -> do
(newCtx, res) <- eval ctx' x preference
(newCtx, res) <- eval ctx' x preference ResolveLocal
case res of
Right okX -> do
let binder = Binder emptyMeta (XObj (Lst [(XObj LetDef Nothing Nothing), XObj (Sym (SymPath [] n) Symbol) Nothing Nothing, okX]) Nothing (xobjTy okX))
@ -360,17 +372,17 @@ eval ctx xobj@(XObj o info ty) preference =
XObj (Match _) _ _ : _ -> pure (ctx, Left (HasStaticCall xobj info))
[XObj Ref _ _, _] -> pure (ctx, Left (HasStaticCall xobj info))
l@(XObj (Lst _) i t) : args -> do
(newCtx, f) <- eval ctx l preference
(newCtx, f) <- eval ctx l preference ResolveLocal
case f of
Right fun -> do
(newCtx', res) <- eval (pushFrame newCtx xobj) (XObj (Lst (fun : args)) i t) preference
(newCtx', res) <- eval (pushFrame newCtx xobj) (XObj (Lst (fun : args)) i t) preference ResolveLocal
pure (popFrame newCtx', res)
x -> pure (newCtx, x)
x@(XObj (Sym _ _) i _) : args -> do
(newCtx, f) <- eval ctx x preference
(newCtx, f) <- eval ctx x preference ResolveLocal
case f of
Right fun -> do
(newCtx', res) <- eval (pushFrame ctx xobj) (XObj (Lst (fun : args)) i ty) preference
(newCtx', res) <- eval (pushFrame ctx xobj) (XObj (Lst (fun : args)) i ty) preference ResolveLocal
pure (popFrame newCtx', res)
Left err -> pure (newCtx, Left err)
XObj With _ _ : xobj'@(XObj (Sym path _) _ _) : forms ->
@ -385,7 +397,7 @@ eval ctx xobj@(XObj o info ty) preference =
successiveEval' (ctx', acc) x =
case acc of
err@(Left _) -> pure (ctx', err)
Right _ -> eval ctx' x preference
Right _ -> eval ctx' x preference ResolveLocal
[XObj While _ _, cond, body] ->
specialCommandWhile ctx cond body
[XObj Address _ _, value] ->
@ -429,7 +441,7 @@ eval ctx xobj@(XObj o info ty) preference =
case acc of
Left _ -> pure (ctx', acc)
Right l -> do
(newCtx, evald) <- eval ctx' x preference
(newCtx, evald) <- eval ctx' x preference ResolveLocal
pure $ case evald of
Right res -> (newCtx, Right (l ++ [res]))
Left err -> (newCtx, Left err)
@ -453,12 +465,12 @@ macroExpand ctx xobj =
ok <- expanded
Right (XObj (StaticArr ok) i t)
)
XObj (Lst [XObj (Lst (XObj Macro _ _ : _)) _ _]) _ _ -> evalDynamic ctx xobj
XObj (Lst [XObj (Lst (XObj Macro _ _ : _)) _ _]) _ _ -> evalDynamic ResolveLocal ctx xobj
XObj (Lst (x@(XObj (Sym _ _) _ _) : args)) i t -> do
(next, f) <- evalDynamic ctx x
(next, f) <- evalDynamic ResolveLocal ctx x
case f of
Right m@(XObj (Lst (XObj Macro _ _ : _)) _ _) -> do
(newCtx', res) <- evalDynamic ctx (XObj (Lst (m : args)) i t)
(newCtx', res) <- evalDynamic ResolveLocal ctx (XObj (Lst (m : args)) i t)
pure (newCtx', res)
-- TODO: Determine a way to eval primitives generally and remove this special case.
Right p@(XObj (Lst [(XObj (Primitive prim) _ _), (XObj (Sym (SymPath _ "defmodule") _) _ _), _]) _ _) ->
@ -524,7 +536,7 @@ apply ctx@Context {contextInternalEnv = internal} body params args =
insideEnv'
(head rest)
(XObj (Lst (drop n args)) Nothing Nothing)
(c, r) <- evalDynamic (ctx {contextInternalEnv = Just insideEnv''}) body
(c, r) <- evalDynamic ResolveLocal (ctx {contextInternalEnv = Just insideEnv''}) body
pure (c {contextInternalEnv = internal}, r)
-- | Parses a string and then converts the resulting forms to commands, which are evaluated in order.
@ -576,25 +588,13 @@ folder context xobj = do
-- | Take a repl command and execute it.
executeCommand :: Context -> XObj -> IO (XObj, Context)
executeCommand ctx s@(XObj (Sym _ _) _ _) =
executeCommand
ctx
( XObj
( Lst
[ XObj (Sym (SymPath [] "info") Symbol) (Just dummyInfo) Nothing,
s
]
)
(Just dummyInfo)
Nothing
)
executeCommand ctx@(Context env _ _ _ _ _ _ _) xobj =
do
when (isJust (envModuleName env)) $
error ("Global env module name is " ++ fromJust (envModuleName env) ++ " (should be Nothing).")
-- The s-expression command is a special case that prefers global/static bindings over dynamic bindings
-- when given a naked binding (no path) as an argument; (s-expr inc)
(newCtx, result) <- if (xobjIsSexp xobj) then evalStatic ctx xobj else evalDynamic ctx xobj
(newCtx, result) <- if (xobjIsSexp xobj) then evalStatic ResolveGlobal ctx xobj else evalDynamic ResolveGlobal ctx xobj
case result of
Left e@(EvalError _ _ _ _) -> do
reportExecutionError newCtx (show e)
@ -698,14 +698,14 @@ specialCommandAddress ctx xobj =
specialCommandWhile :: Context -> XObj -> XObj -> IO (Context, Either EvalError XObj)
specialCommandWhile ctx cond body = do
(newCtx, evd) <- evalDynamic ctx cond
(newCtx, evd) <- evalDynamic ResolveLocal ctx cond
case evd of
Right c ->
case xobjObj c of
Bol b ->
if b
then do
(newCtx', _) <- evalDynamic newCtx body
(newCtx', _) <- evalDynamic ResolveLocal newCtx body
specialCommandWhile newCtx' cond body
else pure (newCtx, dynamicNil)
_ ->
@ -750,7 +750,7 @@ annotateWithinContext qualifyDefn ctx xobj = do
case sig of
Left err -> pure (ctx, Left err)
Right okSig -> do
(_, expansionResult) <- expandAll evalDynamic ctx xobj
(_, expansionResult) <- expandAll (evalDynamic ResolveLocal) ctx xobj
case expansionResult of
Left err -> pure (evalError ctx (show err) Nothing)
Right expanded ->
@ -813,7 +813,7 @@ primitiveDefmodule xobj ctx@(Context env i _ pathStrings _ _ _ _) (XObj (Sym (Sy
(macroExpand ctx' expressions)
>>= \(ctx'', res) -> case res of
Left _ -> pure (ctx'', res)
Right r -> evalDynamic ctx'' r
Right r -> evalDynamic ResolveLocal ctx'' r
primitiveDefmodule _ ctx (x : _) =
pure (evalError ctx ("`defmodule` expects a symbol, got '" ++ pretty x ++ "' instead.") (xobjInfo x))
primitiveDefmodule _ ctx [] =
@ -1061,7 +1061,7 @@ commandC :: UnaryCommandCallback
commandC ctx xobj = do
let globalEnv = contextGlobalEnv ctx
typeEnv = contextTypeEnv ctx
(newCtx, result) <- expandAll evalDynamic ctx xobj
(newCtx, result) <- expandAll (evalDynamic ResolveLocal) ctx xobj
case result of
Left err -> pure (newCtx, Left err)
Right expanded ->
@ -1128,7 +1128,7 @@ buildMainFunction xobj =
primitiveDefdynamic :: Primitive
primitiveDefdynamic _ ctx [XObj (Sym (SymPath [] name) _) _ _, value] = do
(newCtx, result) <- evalDynamic ctx value
(newCtx, result) <- evalDynamic ResolveLocal ctx value
case result of
Left err -> pure (newCtx, Left err)
Right evaledBody ->
@ -1139,7 +1139,7 @@ primitiveDefdynamic _ _ _ = error "primitivedefdynamic"
specialCommandSet :: Context -> [XObj] -> IO (Context, Either EvalError XObj)
specialCommandSet ctx [(XObj (Sym path@(SymPath mod n) _) _ _), val] = do
(newCtx, result) <- evalDynamic ctx val
(newCtx, result) <- evalDynamic ResolveLocal ctx val
case result of
Left err -> pure (newCtx, Left err)
Right evald -> do
@ -1215,7 +1215,7 @@ setStaticOrDynamicVar path env binder value =
primitiveEval :: Primitive
primitiveEval _ ctx [val] = do
-- primitives don’t evaluate their arguments, so this needs to double-evaluate
(newCtx, arg) <- evalDynamic ctx val
(newCtx, arg) <- evalDynamic ResolveLocal ctx val
case arg of
Left err -> pure (newCtx, Left err)
Right evald -> do
@ -1223,7 +1223,7 @@ primitiveEval _ ctx [val] = do
case expanded of
Left err -> pure (newCtx', Left err)
Right ok -> do
(finalCtx, res) <- evalDynamic newCtx' ok
(finalCtx, res) <- evalDynamic ResolveLocal newCtx' ok
pure $ case res of
Left (HasStaticCall x i) -> evalError ctx ("Unexpected static call in " ++ pretty x) i
_ -> (finalCtx, res)
@ -1253,13 +1253,13 @@ primitiveDefmacro _ _ _ = error "primitivedefmacro"
primitiveAnd :: Primitive
primitiveAnd _ ctx [a, b] = do
(newCtx, evaledA) <- evalDynamic ctx a
(newCtx, evaledA) <- evalDynamic ResolveLocal ctx a
case evaledA of
Left e -> pure (ctx, Left e)
Right (XObj (Bol ab) _ _) ->
if ab
then do
(newCtx', evaledB) <- evalDynamic newCtx b
(newCtx', evaledB) <- evalDynamic ResolveLocal newCtx b
pure $ case evaledB of
Left e -> (newCtx, Left e)
Right (XObj (Bol bb) _ _) ->
@ -1271,14 +1271,14 @@ primitiveAnd _ _ _ = error "primitiveand"
primitiveOr :: Primitive
primitiveOr _ ctx [a, b] = do
(newCtx, evaledA) <- evalDynamic ctx a
(newCtx, evaledA) <- evalDynamic ResolveLocal ctx a
case evaledA of
Left e -> pure (ctx, Left e)
Right (XObj (Bol ab) _ _) ->
if ab
then pure (newCtx, Right trueXObj)
else do
(newCtx', evaledB) <- evalDynamic newCtx b
(newCtx', evaledB) <- evalDynamic ResolveLocal newCtx b
pure $ case evaledB of
Left e -> (newCtx, Left e)
Right (XObj (Bol bb) _ _) ->

11
src/Obj.hs
View File

@ -1024,3 +1024,14 @@ emptyList = XObj (Lst []) Nothing Nothing
wrapInRefTyIfMatchRef :: MatchMode -> Ty -> Ty
wrapInRefTyIfMatchRef MatchRef t = RefTy t (VarTy "whatever") -- TODO: Better name for the lifetime variable.
wrapInRefTyIfMatchRef MatchValue t = t
-- | Check if the Obj is static and resolvable
isResolvableStaticObj :: Obj -> Bool
isResolvableStaticObj Def = True
isResolvableStaticObj (Defn _) = True
isResolvableStaticObj (External _) = True
isResolvableStaticObj (Deftemplate _) = True
isResolvableStaticObj (Instantiate _) = True
isResolvableStaticObj (Fn _ _) = True
isResolvableStaticObj (Interface _ _) = True
isResolvableStaticObj _ = False