fix: Closure context (#1124)

* feat: add semigroup instance for Env and Context

Adds a semigroup instance for combining Envs and Contexts--this will be
necessary to ensure closure's are evaluated under the combination of the
context captured in the closure and the current global context during
evaluation.

The semigroup instances are left biased and will prefer bindings defined
in the left context/env argument in the case of conflicts (this is in
keeping with the implementation of `union` in Data.Map, the underlying
function powering this instance).

* fix: evaluate closures under the current context

Previously, closures were evaluated only under the context that was
stored during their creation. However, this can lead to issues where
closures do not resolve bindings to their latest definitions.

This commit leverages the semigroup instance of Context to evaluate
closures under the combination of the context captured during their
creation and the broader context during their evaluation/application,
preferring the context captured in the closure when bindings conflict.

This ensures that when we apply closures their local bindings still
resolve to definitions encapsulated in the closure, while other bindings
resolve to the definitions contained in the current overarching context
(instead of the old context captured by the closure).

* fix: fix bias for context env combinations in semigroup

Previously, the semigroup instance for Context was left-biased in all
the combinations of each context's environment. However, one usually
calls this function to combine some older context with a newer context,
intending to have the older context win *only* in the case of internal
environments.

This commit changes the behavior of the semigroup instance to better
reflect this use case. When one calls:

`c <> c'`

The envs in each context are combined as follows:

- internal: If conflicts occur, prefer the bindings of the context on
  the LHS (the "older" context)
- global: If conflicts occur, prefer the bindings of the context on the
  RHS ("newer" context)
- type: If conflicts occur, prefer the bindings of the context on the
  RHS ("newer" context)

This ensures the resulting context uses the latest values in the chance
of conflicts in the global env/type env, and the older values in the
case of an internal env (a closure).

* test: add basic tests for closures

* refactor: rename test/closure -> test/dynamic-closure

Also updates the forms to test dynamic closures.

src/Eval.hs

@@ -313,7 +313,7 @@ eval ctx xobj@(XObj o info ty) preference resolver =
                 (newCtx, evaledArgs) <- foldlM successiveEval (ctx, Right []) args
                 case evaledArgs of
                   Right okArgs -> do
-                    (_, res) <- apply c{contextHistory=contextHistory ctx} body params okArgs
+                    (_, res) <- apply (c {contextHistory = contextHistory ctx} <> ctx) body params okArgs
                     pure (newCtx, res)
                   Left err -> pure (newCtx, Left err)
         XObj (Lst [XObj Dynamic _ _, sym, XObj (Arr params) _ _, body]) i _ : args ->

src/Map.hs

@@ -40,3 +40,6 @@ keys (Map m) = M.keys m
 
 map :: (a -> b) -> Map k a -> Map k b
 map f (Map m) = Map $ M.map f m
+
+union :: Ord k => Map k v -> Map k v -> Map k v
+union (Map m) (Map m') = (Map (M.union m m'))

src/Obj.hs

@@ -3,6 +3,7 @@
 
 module Obj where
 
+import Control.Applicative
 import Control.Monad.State
 import Data.Char
 import Data.Hashable
@@ -1042,3 +1043,40 @@ isResolvableStaticObj (Instantiate _) = True
 isResolvableStaticObj (Fn _ _) = True
 isResolvableStaticObj (Interface _ _) = True
 isResolvableStaticObj _ = False
+
+-- | Left biased semigroup instance for Envs.
+instance Semigroup Env where
+  e <> e' =
+    let bindings = envBindings e
+        bindings' = envBindings e'
+        joinedParents =
+          (envParent e >>= \p -> (pure p <|> (envParent e' >>= \p' -> pure (p <> p'))))
+            <|> envParent e'
+        joinedUseModules = envUseModules e <> envUseModules e'
+     in e
+          { envBindings = Map.union bindings bindings',
+            envParent = joinedParents,
+            envUseModules = joinedUseModules
+          }
+
+-- | Semigroup instance for Contexts
+--   - Left biased in internal env combination
+--   - Right biased in global env combination
+--   - Right biased in type env combination
+--  The assumption here is that the context on the LHS is the *older* context
+--  in the case of conflicts, we prefer the bindings on the RHS *except* for
+--  the internal environment, since retaining some bindings from the internal
+--  env is typically the reason you'd call this function.
+instance Semigroup Context where
+  c <> c' =
+    let global = contextGlobalEnv c
+        global' = contextGlobalEnv c'
+        internal = contextInternalEnv c
+        internal' = contextInternalEnv c'
+        typeEnv = getTypeEnv (contextTypeEnv c)
+        typeEnv' = getTypeEnv (contextTypeEnv c')
+     in c
+          { contextGlobalEnv = global' <> global,
+            contextInternalEnv = internal <> internal',
+            contextTypeEnv = TypeEnv (typeEnv' <> typeEnv)
+          }

test/dynamic-closures.carp

@@ -0,0 +1,58 @@
+(load "Test.carp")
+(use Test)
+
+(defdynamic x 400)
+
+;; close over a global variable
+(defdynamic closure-one
+  (fn [] x))
+
+;; close over an argument
+(defdynamic closure-two
+  (fn [x] x))
+
+;; close over a let binding
+(defdynamic closure-three
+  (fn [] (let [x 4] x)))
+
+;; dynamics can close over a global variable before it is defined
+(defdynamic closure-four
+  (fn [] y))
+
+;; nested closures prefer closed-over internal environments
+(defdynamic closure-five
+  (fn [] (let [x 5] (fn [] x))))
+
+(defdynamic y 500)
+
+(defmacro test-closure-one [] (closure-one))
+(defmacro test-closure-two [] (closure-two 3))
+(defmacro test-closure-three [] (closure-three))
+(defmacro test-closure-four [] (closure-four))
+(defmacro test-closure-five [] ((closure-five)))
+
+;; Change the global value of x (closed over in closure-one)
+(set! x 1000)
+
+(deftest test
+  (assert-equal test
+    1000
+    (test-closure-one)
+    "closures over global variables get the global variable's latest state.")
+  (assert-equal test
+    3
+    (test-closure-two)
+    "closures with arguments use argument values")
+  (assert-equal test
+    4
+    (test-closure-three)
+    "closures with let bindings prefer let bindings over global names")
+  (assert-equal test
+    500
+    (test-closure-four)
+    "dynamic closures can refer to global bindings delcared after the closure")
+  (assert-equal test
+    5
+    (test-closure-five)
+    "nested closures prefer closed-over bindings")
+)