Implement closures

src/Angle/Exec/Builtins.hs

@@ -79,9 +79,9 @@ import System.IO.Error ( tryIOError
 import System.Process (readProcess)
 
 import Angle.Exec.Error
-import Angle.Exec.Scope
 import Angle.Exec.Types
 import Angle.Types.Lang
+import Angle.Types.Scope
 
 
 emptyArgs :: ArgSig
@@ -108,7 +108,7 @@ builtinVar name = (name, VarVal
                            , varBuiltin = True })
 
 
-builtinsVars :: BindEnv Lambda
+builtinsVars :: BindEnv LangIdent Lambda
 builtinsVars = bindEnvFromList $
                map (builtinVar . LangIdent) builtins
 
@@ -119,7 +119,7 @@ builtinValue name val = (name, VarVal
                                  , varBuiltin = True })
 
 
-builtinsValues :: BindEnv LangLit
+builtinsValues :: BindEnv LangIdent LangLit
 builtinsValues = bindEnvFromList $
                  map (\(x,y) -> builtinValue (LangIdent x) y) builtinValues
 

src/Angle/Exec/Exec.hs

@@ -25,9 +25,9 @@ import Angle.Parse.Parser (program, evalParse)
 import Angle.Exec.Builtins
 import Angle.Exec.Error
 import Angle.Exec.Operations
-import Angle.Exec.Scope
 import Angle.Exec.Types
 import Angle.Types.Lang
+import Angle.Types.Scope
 
 
 updatePos :: SourceRef -> ExecIO ()
@@ -49,15 +49,15 @@ newScope = do
   put env { currentScope = newScope' }
 
 
-lookupVar :: (Scope -> BindEnv a) -> LangIdent -> ExecIO (Maybe a)
+lookupVar :: (Scope -> BindEnv LangIdent a) -> LangIdent -> ExecIO (Maybe a)
 lookupVar binds name = do
   currScope <- getScope
   case resolve binds name currScope of
     Nothing -> return Nothing
     Just x  -> return $ varDef x
 
 
-lookupVarF :: (Scope -> BindEnv a) -> (LangIdent -> ExecError) -> LangIdent -> ExecIO a
+lookupVarF :: (Scope -> BindEnv LangIdent a) -> (LangIdent -> ExecError) -> LangIdent -> ExecIO a
 lookupVarF binds err name = lookupVar binds name
                         >>= maybe (throwExecError $ err name)
                             return
@@ -85,7 +85,7 @@ modifyScope f = do
   put env {currentScope=newScope'}
 
 
-lookupVarCurrentScope :: (Scope -> BindEnv a) -> LangIdent -> ExecIO (Maybe (VarVal a))
+lookupVarCurrentScope :: (Scope -> BindEnv LangIdent a) -> LangIdent -> ExecIO (Maybe (VarVal a))
 lookupVarCurrentScope binds name = do
   currScope <- liftM currentScope get
   if isDefinedIn binds name currScope
@@ -104,7 +104,7 @@ assignVarLit n v = assignVar valueBindings handleBuiltinAssignLit
 
 
 assignVar
-  :: (Scope -> BindEnv a)
+  :: (Scope -> BindEnv LangIdent a)
      -> (LangIdent -> b -> ExecIO b) -- ^ Builtin handler function.
      -> (LangIdent -> VarVal b -> Scope -> Scope)
      -> LangIdent
@@ -321,6 +321,14 @@ callFun x asClass args | isBuiltin x = callBuiltin x args
 
 
 callLambda :: Lambda -> Bool -> [Expr] -> ExecIO LangLit
+callLambda l@(Lambda { lambdaScope = (Just s) }) asClass args
+    = do
+    cScope <- getScope
+    modifyScope (const s)
+    res <- callLambda l { lambdaScope = Nothing } asClass args
+        `catchAE` (\e -> modifyScope (const cScope) >> throwError e)
+    modifyScope (const cScope)
+    return res
 callLambda (Lambda
             { lambdaArgs=params
             , lambdaBody=body}) asClass args
@@ -355,7 +363,13 @@ execSingStmt (StmtReturn x) = do
   isGlob <- liftM (isOutermostScope . currentScope) get
   if isGlob
       then throwExecError returnFromGlobalErr
-      else execExpr x >>= throwReturn
+      else do
+          res <- execExpr x
+          case res of
+              LitLambda lam -> do
+                  sc <- getScope
+                  throwReturn $ LitLambda lam { lambdaScope = Just sc }
+              y -> throwReturn y
 execSingStmt (StmtBreak x False)
     = case x of
         Nothing -> throwBreak Nothing
@@ -525,7 +539,7 @@ assignVarBuiltinLambda =
 
 
 assignVarBuiltin
-  :: (Scope -> BindEnv a)
+  :: (Scope -> BindEnv LangIdent a)
      -> (LangIdent -> VarVal b -> Scope -> Scope)
      -> LangIdent
      -> b -- ^ Value to assign.

src/Angle/Exec/Types/Internal.hs

@@ -37,8 +37,8 @@ import Control.Monad.Trans.Except
 import Control.Monad.State
 
 import Angle.Exec.Error
-import Angle.Exec.Scope
 import Angle.Types.Lang
+import Angle.Types.Scope
 
 
 -- | Angle program execution monad.

src/Angle/Parse/Parser/Internal.hs

@@ -238,7 +238,7 @@ structDefun = StructDefun
               <$> (string "defun " *> identName)
               <*> (Lambda
                    <$> callList <* tokStmtBetween
-                   <*> stmt)
+                   <*> stmt <*> return Nothing)
 
 
 -- | Exception handling.
@@ -436,7 +436,7 @@ lambda :: Parser Lambda
 lambda = parens $ do
     args <- callList <* tokNSpaced
     body <- stmt
-    return $ Lambda args body
+    return $ Lambda args body Nothing
 
 
 -- | Set of arguments for a function

src/Angle/Types/Lang.hs

@@ -102,6 +102,7 @@ module Angle.Types.Lang
     , typeAnnOf
     , ArgElt(..)
     , Lambda(..)
+    , Scope
     , enumType
     , allType
     ) where
@@ -110,6 +111,10 @@ import Numeric (showFFloat)
 import System.IO (Handle)
 
 import Angle.Scanner (SourcePos, beginningOfFile)
+import Angle.Types.Scope (GenScope)
+
+
+type Scope = GenScope LangIdent LangLit Lambda
 
 
 -- | Wraps statements to allow for positional tracking as well
@@ -245,13 +250,14 @@ showSynOpList = showSynSep " " ")" " "
 -- The body is the code that is executed upon successful invokation.
 data Lambda = Lambda { lambdaArgs :: ArgSig
                      , lambdaBody :: Stmt
+                     , lambdaScope :: Maybe Scope
                      } deriving (Show, Eq)
 
 
 instance ShowSyn Lambda where
-    showSyn (Lambda args body@(SingleStmt _ _))
+    showSyn (Lambda args body@(SingleStmt _ _) _)
          = concat ["(", showSyn args, " ", init $ showSyn body, ")"]
-    showSyn (Lambda args body) = concat ["(", showSyn args, " ", showSyn body, ")"]
+    showSyn (Lambda args body _) = concat ["(", showSyn args, " ", showSyn body, ")"]
 
 
 -- | An argument signature.
@@ -477,7 +483,7 @@ instance ShowSyn Expr where
     showSyn (ExprList _) = error "showSyn - cannot show unevaluated list"
     showSyn (ExprRange{}) = error "showSyn - cannot show unevaluated range"
     showSyn (ExprLambdaCall x xs) = showSyn (LitLambda x) ++ " : (" ++ showSynArgs xs ++ ")"
-    showSyn (ExprParamExpand _) = error "showSyn - ExprParamExpand made it to showSyn"
+    showSyn (ExprParamExpand x) = ".." ++ showSyn x -- error "showSyn - ExprParamExpand made it to showSyn"
 
 
 -- | Represents names that can be assigned values.