Write Yourself a Scheme in 48 Hours/Defining Scheme Functions

Now that we can define variables, we might as well extend it to functions. After this section, you'll be able to define your own functions within Scheme and use them from other functions. Our implementation is nearly finished.

Let's start by defining new LispVal constructors:

| PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
| Func { params :: [String], vararg :: (Maybe String),
         body :: [LispVal], closure :: Env }

We've added a separate constructor for primitives, because we'd like to be able to store +, eqv?, etc. in variables and pass them to functions. The PrimitiveFunc constructor stores a function that takes a list of arguments to a ThrowsError LispVal, the same type that is stored in our primitive list.

We also want a constructor to store user-defined functions. We store four pieces of information:

1. the names of the parameters, as they're bound in the function body;
2. whether the function accepts a variable-length list of arguments, and if so, the variable name it's bound to;
3. the function body, as a list of expressions;
4. the environment that the function was created in.

This is an example of a record type. Records are somewhat clumsy in Haskell, so we're only using them for demonstration purposes. However, they can be invaluable in large-scale programming.

Next, we'll want to edit our show function to include the new types:

showVal (PrimitiveFunc _) = "<primitive>"
showVal (Func {params = args, vararg = varargs, body = body, closure = env}) =
   "(lambda (" ++ unwords (map show args) ++
      (case varargs of
         Nothing -> ""
         Just arg -> " . " ++ arg) ++ ") ...)"

Instead of showing the full function, we just print out the word <primitive> for primitives and the header info for user-defined functions. This is an example of pattern-matching for records: as with normal algebraic types, a pattern looks exactly like a constructor call. Field names come first and the variables they'll be bound to come afterwards.

Next, we need to change apply. Instead of being passed the name of a function, it'll be passed a LispVal representing the actual function. For primitives, that makes the code simpler: we need only read the function out of the value and apply it.

apply :: LispVal -> [LispVal] -> IOThrowsError LispVal
apply (PrimitiveFunc func) args = liftThrows $ func args

The interesting code happens when we're faced with a user defined function. Records let you pattern match on both the field name (as shown above) or the field position, so we'll use the latter form:

apply (Func params varargs body closure) args =
      if num params /= num args && varargs == Nothing
         then throwError $ NumArgs (num params) args
         else (liftIO $ bindVars closure $ zip params args) >>= bindVarArgs varargs >>= evalBody
      where remainingArgs = drop (length params) args
            num = toInteger . length
            evalBody env = liftM last $ mapM (eval env) body
            bindVarArgs arg env = case arg of
                Just argName -> liftIO $ bindVars env [(argName, List $ remainingArgs)]
                Nothing -> return env

The very first thing this function does is check the length of the parameter list against the expected number of arguments. It throws an error if they don't match. We define a local function num to enhance readability and make the program a bit shorter.

Assuming the call is valid, we do the bulk of the call in monadic pipeline that binds the arguments to a new environment and executes the statements in the body. The first thing we do is zip the list of parameter names and the list of (already evaluated) argument values together into a list of pairs. Then, we take that and the function's closure (not the current environment – this is what gives us lexical scoping) and use them to create a new environment to evaluate the function in. The result is of type IO, while the function as a whole is IOThrowsError, so we need to liftIO it into the combined monad.

Now it's time to bind the remaining arguments to the varargs variable, using the local function bindVarArgs. If the function doesn't take varargs (the Nothing clause), then we just return the existing environment. Otherwise, we create a singleton list that has the variable name as the key and the remaining args as the value, and pass that to bindVars. We define the local variable remainingArgs for readability, using the built-in function drop to ignore all the arguments that have already been bound to variables.

The final stage is to evaluate the body in this new environment. We use the local function evalBody for this, which maps the monadic function eval env over every statement in the body, and then returns the value of the last statement.

Since we're now storing primitives as regular values in variables, we have to bind them when the program starts up:

primitiveBindings :: IO Env
primitiveBindings = nullEnv >>= (flip bindVars $ map makePrimitiveFunc primitives)
     where makePrimitiveFunc (var, func) = (var, PrimitiveFunc func)

This takes the initial null environment, makes a bunch of name/value pairs consisting of PrimitiveFunc wrappers, and then binds the new pairs into the new environment. We also want to change runOne and runRepl to primitiveBindings instead:

runOne :: String -> IO ()
runOne expr = primitiveBindings >>= flip evalAndPrint expr

runRepl :: IO ()
runRepl = primitiveBindings >>= until_ (== "quit") (readPrompt "Lisp>>> ") . evalAndPrint

Finally, we need to change the evaluator to support lambda and function define. We'll start by creating a few helper functions to make it a little easier to create function objects in the IOThrowsError monad:

makeFunc varargs env params body = return $ Func (map showVal params) varargs body env
makeNormalFunc = makeFunc Nothing
makeVarArgs = makeFunc . Just . showVal

Here, makeNormalFunc and makeVarArgs should just be considered specializations of makeFunc with the first argument set appropriately for normal functions vs. variable args. This is a good example of how to use first-class functions to simplify code.

Now, we can use them to add our extra eval clauses. They should be inserted after the define-variable clause and before the function-application one:

eval env (List (Atom "define" : List (Atom var : params) : body)) =
     makeNormalFunc env params body >>= defineVar env var
eval env (List (Atom "define" : DottedList (Atom var : params) varargs : body)) =
     makeVarArgs varargs env params body >>= defineVar env var
eval env (List (Atom "lambda" : List params : body)) =
     makeNormalFunc env params body
eval env (List (Atom "lambda" : DottedList params varargs : body)) =
     makeVarArgs varargs env params body
eval env (List (Atom "lambda" : varargs@(Atom _) : body)) =
     makeVarArgs varargs env [] body

The following needs to replace the prior function-application eval clause.

eval env (List (function : args)) = do
     func <- eval env function
     argVals <- mapM (eval env) args
     apply func argVals

As you can see, they just use pattern matching to destructure the form and then call the appropriate function helper. In define's case, we also feed the output into defineVar to bind a variable in the local environment. We also need to change the function application clause to remove the liftThrows function, since apply now works in the IOThrowsError monad.

We can now compile and run our program, and use it to write real programs!

$ ghc -package parsec -fglasgow-exts -o lisp [../code/listing9.hs listing9.hs]
$ ./lisp
Lisp>>> (define (f x y) (+ x y))
(lambda ("x" "y") ...)
Lisp>>> (f 1 2)
3
Lisp>>> (f 1 2 3)
Expected 2 args; found values 1 2 3
Lisp>>> (f 1)
Expected 2 args; found values 1
Lisp>>> (define (factorial x) (if (= x 1) 1 (* x (factorial (- x 1)))))
(lambda ("x") ...)
Lisp>>> (factorial 10)
3628800
Lisp>>> (define (counter inc) (lambda (x) (set! inc (+ x inc)) inc))
(lambda ("inc") ...)
Lisp>>> (define my-count (counter 5))
(lambda ("x") ...)
Lisp>>> (my-count 3)
8
Lisp>>> (my-count 6)
14
Lisp>>> (my-count 5)
19