Merge branch 'master' into fix413s

src/Control/Abstract/Heap.hs

@@ -10,7 +10,6 @@ module Control.Abstract.Heap
 , alloc
 , deref
 , assign
-, lookupOrAlloc
 , letrec
 , letrec'
 , variable

src/Control/Abstract/Primitive.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FunctionalDependencies, UndecidableInstances #-}
 module Control.Abstract.Primitive
   ( define
   , defineClass
@@ -5,6 +6,7 @@ module Control.Abstract.Primitive
   , builtInPrint
   , builtInExport
   , lambda
+  , Lambda(..)
   ) where
 
 import Control.Abstract.Context
@@ -60,17 +62,33 @@ defineNamespace name scope = define name $ do
   binds <- Env.head <$> locally (scope >> getEnv)
   namespace name Nothing binds
 
+-- | Construct a function from a Haskell function taking 'Name's as arguments.
+--
+-- The constructed function will have the same arity as the Haskell function. Nullary functions are constructed by providing an evaluator producing an address. Note that the constructed function must not contain free variables as they will not be captured by the closure, and/or will be garbage collected.
 lambda :: ( HasCallStack
-          , Member Fresh effects
-          , Member (Function address value) effects
+          , Lambda address value effects fn
           , Member (Reader ModuleInfo) effects
           , Member (Reader Span) effects
           )
-       => (Name -> Evaluator address value effects address)
+       => fn
        -> Evaluator address value effects value
-lambda body = withCurrentCallStack callStack $ do
-  var <- gensym
-  function [var] lowerBound (body var)
+lambda body = withCurrentCallStack callStack (lambda' [] body)
+
+-- | A class of types forming the body of 'lambda's. Note that there should in general only be two cases: a recursive case of functions taking 'Name's as parameters, and a base case of an 'Evaluator'.
+class Lambda address value effects ty | ty -> address, ty -> value, ty -> effects where
+  lambda' :: [Name]
+          -> ty
+          -> Evaluator address value effects value
+
+instance (Member Fresh effects, Lambda address value effects ret) => Lambda address value effects (Name -> ret) where
+  lambda' vars body = do
+    var <- gensym
+    lambda' (var : vars) (body var)
+  {-# INLINE lambda' #-}
+
+instance Member (Function address value) effects => Lambda address value effects (Evaluator address value effects address) where
+  lambda' vars body = function vars lowerBound body
+  {-# INLINE lambda' #-}
 
 builtInPrint :: ( AbstractValue address value effects
                 , HasCallStack

src/Data/Abstract/Evaluatable.hs

@@ -169,7 +169,7 @@ instance HasPrelude 'Ruby where
     define (name "puts") builtInPrint
 
     defineClass (name "Object") [] $ do
-      define (name "inspect") (lambda (const (box (string "<object>"))))
+      define (name "inspect") (lambda (box (string "<object>")))
 
 instance HasPrelude 'TypeScript where
   definePrelude _ =

src/Data/Syntax/Declaration.hs

@@ -256,9 +256,7 @@ instance Show1 TypeAlias where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable TypeAlias where
   eval TypeAlias{..} = do
     name <- maybeM (throwEvalError NoNameError) (declaredName (subterm typeAliasIdentifier))
-    v <- subtermValue typeAliasKind
-    addr <- lookupOrAlloc name
-    assign addr v
+    addr <- subtermAddress typeAliasKind
     bind name addr
     pure (Rval addr)
 

src/Data/Syntax/Statement.hs

@@ -118,13 +118,11 @@ instance Show1 Assignment where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Assignment where
   eval Assignment{..} = do
     lhs <- subtermRef assignmentTarget
-    rhs <- subtermValue assignmentValue
+    rhs <- subtermAddress assignmentValue
 
     case lhs of
       LvalLocal nam -> do
-        addr <- lookupOrAlloc nam
-        assign addr rhs
-        bind nam addr
+        bind nam rhs
       LvalMember _ _ ->
         -- we don't yet support mutable object properties:
         pure ()
@@ -132,7 +130,7 @@ instance Evaluatable Assignment where
         -- the left hand side of the assignment expression is invalid:
         pure ()
 
-    rvalBox rhs
+    pure (Rval rhs)
 
 -- | Post increment operator (e.g. 1++ in Go, or i++ in C).
 newtype PostIncrement a = PostIncrement a

src/Language/TypeScript/Syntax/TypeScript.hs

@@ -110,9 +110,7 @@ instance Evaluatable DefaultExport where
   eval (DefaultExport term) = do
     case declaredName term of
       Just name -> do
-        addr <- lookupOrAlloc name
-        v <- subtermValue term
-        assign addr v
+        addr <- subtermAddress term
         export name name Nothing
         bind name addr
       Nothing -> throwEvalError DefaultExportError