# Write Yourself a Scheme in 48 Hours/Evaluation, Part 2

## Additional Primitives: Partial Application

Now that we can deal with type errors, bad arguments, and so on, we\'ll
flesh out our primitive list so that it does something more than
calculate. We\'ll add boolean operators, conditionals, and some basic
string operations.

Start by adding the following into the list of primitives:

``` haskell
("=", numBoolBinop (==)),
("<", numBoolBinop (<)),
(">", numBoolBinop (>)),
("/=", numBoolBinop (/=)),
(">=", numBoolBinop (>=)),
("<=", numBoolBinop (<=)),
("&&", boolBoolBinop (&&)),
("||", boolBoolBinop (||)),
("string=?", strBoolBinop (==)),
("string<?", strBoolBinop (<)),
("string>?", strBoolBinop (>)),
("string<=?", strBoolBinop (<=)),
("string>=?", strBoolBinop (>=)),
```

These depend on helper functions that we haven\'t written yet:
`numBoolBinop`, `boolBoolBinop` and `strBoolBinop`. Instead of taking a
variable number of arguments and returning an integer, these both take
exactly two arguments and return a boolean. They differ from each other
only in the type of argument they expect, so let\'s factor the
duplication into a generic `boolBinop` function that\'s parametrized by
the unpacker function it applies to its arguments:

``` haskell
boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop unpacker op args = if length args /= 2
                             then throwError $ NumArgs 2 args
                             else do left <- unpacker $ args !! 0
                                      right <- unpacker $ args !! 1
                                      return $ Bool $ left `op` right
```

Because each argument may throw a type mismatch, we have to unpack them
sequentially, in a do-block (for the `Error` monad). We then apply the
operation to the two arguments and wrap the result in the `Bool`
constructor. Any function can be turned into an infix operator by
wrapping it in backticks (`` `op` ``).

Also, take a look at the type signature. `boolBinop` takes *two*
functions as its first two arguments: the first is used to unpack the
arguments from `LispVal`s to native Haskell types, and the second is the
actual operation to perform. By parameterizing different parts of the
behavior, you make the function more reusable.

Now we define three functions that specialize `boolBinop` with different
unpackers:

``` haskell
numBoolBinop  = boolBinop unpackNum
strBoolBinop  = boolBinop unpackStr
boolBoolBinop = boolBinop unpackBool
```

We haven\'t told Haskell how to unpack strings from `LispVal`s yet. This
works similarly to `unpackNum`, pattern matching against the value and
either returning it or throwing an error. Again, if passed a primitive
value that could be interpreted as a string (such as a number or
boolean), it will silently convert it to the string representation.

``` haskell
unpackStr :: LispVal -> ThrowsError String
unpackStr (String s) = return s
unpackStr (Number s) = return $ show s
unpackStr (Bool s)   = return $ show s
unpackStr notString  = throwError $ TypeMismatch "string" notString
```

And we use similar code to unpack booleans:

``` haskell
unpackBool :: LispVal -> ThrowsError Bool
unpackBool (Bool b) = return b
unpackBool notBool  = throwError $ TypeMismatch "boolean" notBool
```

Let\'s compile and test this to make sure it\'s working, before we
proceed to the next feature:

`$ ghc -package parsec -o simple_parser [../code/listing6.1.hs listing6.1.hs]`\
`$ ./simple_parser "(< 2 3)"`\
`#t`\
`$ ./simple_parser "(> 2 3)"`\
`#f`\
`$ ./simple_parser "(>= 3 3)"`\
`#t`\
`$ ./simple_parser "(string=? \"test\"  \"test\")"`\
`#t`\
`$ ./simple_parser "(string<? \"abc\" \"bba\")"`\
`#t`

## Conditionals: Pattern Matching 2

Now, we\'ll proceed to adding an if-clause to our evaluator. As with
standard Scheme, our evaluator considers `#f` to be false and any other
value to be true:

``` haskell
eval (List [Atom "if", pred, conseq, alt]) =
     do result <- eval pred
        case result of
             Bool False -> eval alt
             otherwise  -> eval conseq
```

As the function definitions are evaluated in order, be sure to place
this one above
`eval (List (Atom func : args)) = mapM eval args >>= apply func` or it
will throw a `Unrecognized primitive function args: "if"` error.

This is another example of nested pattern-matching. Here, we\'re looking
for a 4-element list. The first element must be the atom `if`. The
others can be any Scheme forms. We take the first element, evaluate, and
if it\'s false, evaluate the alternative. Otherwise, we evaluate the
consequent.

Compile and run this, and you\'ll be able to play around with
conditionals:

`$ ghc -package parsec -o simple_parser [../code/listing6.2.hs listing6.2.hs]`\
`$ ./simple_parser "(if (> 2 3) \"no\" \"yes\")"`\
`"yes"`\
`$ ./simple_parser "(if (= 3 3) (+ 2 3 (- 5 1)) \"unequal\")"`\
`9`

## List Primitives: `car`, `cdr`, and `cons`

For good measure, let\'s also add in the basic list-handling primitives.
Because we\'ve chosen to represent our lists as Haskell algebraic data
types instead of pairs, these are somewhat more complicated than their
definitions in many Lisps. It\'s easiest to think of them in terms of
their effect on printed S-expressions:

1.  `(car '(a b c)) = a`
2.  `(car '(a)) = a`
3.  `(car '(a b . c)) = a`
4.  `(car 'a) = error` -- not a list
5.  `(car 'a 'b) = error` -- `car` only takes one argument

We can translate these fairly straightforwardly into pattern clauses,
recalling that `(x : xs)` divides a list into the first element and the
rest:

``` haskell
car :: [LispVal] -> ThrowsError LispVal
car [List (x : xs)]         = return x
car [DottedList (x : xs) _] = return x
car [badArg]                = throwError $ TypeMismatch "pair" badArg
car badArgList              = throwError $ NumArgs 1 badArgList
```

Let\'s do the same with cdr:

1.  `(cdr '(a b c)) = (b c)`
2.  `(cdr '(a b)) = (b)`
3.  `(cdr '(a)) = NIL`
4.  `(cdr '(a . b)) = b`
5.  `(cdr '(a b . c)) = (b . c)`
6.  `(cdr 'a) = error` -- not a list
7.  `(cdr 'a 'b) = error` -- too many arguments

We can represent the first three cases with a single clause. Our parser
represents `'()` as `List []`, and when you pattern-match `(x : xs)`
against `[x]`, `xs` is bound to `[]`. The other ones translate to
separate clauses:

``` haskell
cdr :: [LispVal] -> ThrowsError LispVal
cdr [List (x : xs)]         = return $ List xs
cdr [DottedList [_] x]      = return x
cdr [DottedList (_ : xs) x] = return $ DottedList xs x
cdr [badArg]                = throwError $ TypeMismatch "pair" badArg
cdr badArgList              = throwError $ NumArgs 1 badArgList
```

`cons` is a little tricky, enough that we should go through each clause
case-by-case. If you cons together anything with `Nil`, you end up with
a one-item list, the `Nil` serving as a terminator:

``` haskell
cons :: [LispVal] -> ThrowsError LispVal
cons [x1, List []] = return $ List [x1]
```

If you `cons` together anything and a list, it\'s like tacking that
anything onto the front of the list:

``` haskell

cons [x, List xs] = return $ List $ x : xs
```

However, if the list is a `DottedList`, then it should stay a
`DottedList`, taking into account the improper tail:

``` haskell
cons [x, DottedList xs xlast] = return $ DottedList (x : xs) xlast
```

If you `cons` together two non-lists, or put a list in front, you get a
`DottedList`. This is because such a `cons` cell isn\'t terminated by
the normal `Nil` that most lists are.

``` haskell
cons [x1, x2] = return $ DottedList [x1] x2
```

Finally, attempting to `cons` together more or less than two arguments
is an error:

``` haskell
cons badArgList = throwError $ NumArgs 2 badArgList
```

Our last step is to implement `eqv?`. Scheme offers three levels of
equivalence predicates: `eq?`, `eqv?`, and
`equal?`.
For our purposes, `eq?` and `eqv?` are basically the same: they
recognize two items as the same if they print the same, and are fairly
slow. So we can write one function for both of them and register it
under `eq?` and `eqv?`.

``` haskell
eqv :: [LispVal] -> ThrowsError LispVal
eqv [(Bool arg1), (Bool arg2)]             = return $ Bool $ arg1 == arg2
eqv [(Number arg1), (Number arg2)]         = return $ Bool $ arg1 == arg2
eqv [(String arg1), (String arg2)]         = return $ Bool $ arg1 == arg2
eqv [(Atom arg1), (Atom arg2)]             = return $ Bool $ arg1 == arg2
eqv [(DottedList xs x), (DottedList ys y)] = eqv [List $ xs ++ [x], List $ ys ++ [y]]
eqv [(List arg1), (List arg2)]             = return $ Bool $ (length arg1 == length arg2) &&
                                                             (all eqvPair $ zip arg1 arg2)
     where eqvPair (x1, x2) = case eqv [x1, x2] of
                                Left err -> False
                                Right (Bool val) -> val
eqv [_, _]                                 = return $ Bool False
eqv badArgList                             = throwError $ NumArgs 2 badArgList
```

Most of these clauses are self-explanatory, the exception being the one
for two `Lists`. This, after checking to make sure the lists are the
same length,
`zip`s
the two lists of pairs, and then uses the function
`all`
to return `False` if `eqvPair` returns `False` on any of the pairs.
`eqvPair` is an example of a local definition: it is defined using the
`where` keyword, just like a normal function, but is available only
within that particular clause of `eqv`. Since we know that `eqv` only
throws an error if the number of arguments is not 2, the line
`Left err -> False` will never be executed at the moment.

## `equal?` and Weak Typing: Heterogenous Lists

Since we introduced weak typing above, we\'d also like to introduce an
`equal?` function that ignores differences in the type tags and only
tests if two values can be interpreted the same. For example,
`(eqv? 2 "2") = #f`, yet we\'d like `(equal? 2 "2") = #t`. Basically, we
want to try all of our unpack functions, and if any of them result in
Haskell values that are equal, return `True`.

The obvious way to approach this is to store the unpacking functions in
a list and use `mapM` to execute them in turn. Unfortunately, this
doesn\'t work, because standard Haskell only lets you put objects in a
list *if they\'re the same type*. The various unpacker functions return
different types, so you can\'t store them in the same list.

We\'ll get around this by using a GHC extension -- Existential
Types -- that lets
us create a heterogenous list, subject to typeclass constraints.
Extensions are fairly common in the Haskell world: they\'re basically
necessary to create any reasonably large program, and they\'re often
compatible between implementations (existential types work in both Hugs
and GHC and are a candidate for standardization). Note you need to use a
special compiler flag for this: `-fglasgow-exts` as mentioned below; the
newer `-XExistentialQuantification`; or add the pragma
`{-# LANGUAGE ExistentialQuantification #-}` to the beginning of your
code (In general, the compiler flag `-Xfoo` can be replaced by the
pragma `{-# LANGUAGE foo #-}` inside the source file).

The first thing we need to do is define a data type that can hold any
function from a `LispVal -> something`, provided that that `something`
supports equality:

``` haskell
data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)
```

This is like any normal algebraic datatype, except for the type
constraint. It says, \"For any type that is an instance of `Eq`, you can
define an `Unpacker` that takes a function from `LispVal` to that type,
and may throw an error\". We\'ll have to wrap our functions with the
`AnyUnpacker` constructor, but then we can create a list of `Unpacker`s
that does just what we want it.

Rather than jump straight to the `equal?` function, let\'s first define
a helper function that takes an `Unpacker` and then determines if two
`LispVal`s are equal when it unpacks them:

``` haskell
unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
unpackEquals arg1 arg2 (AnyUnpacker unpacker) =
             do unpacked1 <- unpacker arg1
                unpacked2 <- unpacker arg2
                return $ unpacked1 == unpacked2
        `catchError` (const $ return False)
```

After pattern-matching to retrieve the actual function, we enter a
do-block for the `ThrowsError` monad. This retrieves the Haskell values
of the two `LispVal`s, and then tests whether they\'re equal. If there
is an error anywhere within the two unpackers, it returns `False`, using
the
`const`
function because
`catchError`
expects a function to apply to the error value.

Finally, we can define `equal?` in terms of these helpers:

``` haskell
equal :: [LispVal] -> ThrowsError LispVal
equal [arg1, arg2] = do
      primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)
                         [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
      eqvEquals <- eqv [arg1, arg2]
      return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)
equal badArgList = throwError $ NumArgs 2 badArgList
```

The first action makes a heterogenous list of
`[unpackNum, unpackStr, unpackBool]`, and then maps the partially
applied `(unpackEquals arg1 arg2)` over it. This gives a list of
booleans, so we use the Prelude function
`or`
to return true if any single one of them is true.

The second action tests the two arguments with `eqv?`. Since we want
`equal?` to be looser than `eqv?`, it should return true whenever `eqv?`
does so. This also lets us avoid handling cases like the list or
dotted-list (though this introduces a bug; see exercise #2 in this
section).

Finally, `equal?` `or`s both of these values together and wraps the
result in the `Bool` constructor, returning a `LispVal`. The
`let (Bool x) = eqvEquals in x` is a quick way of extracting a value
from an algebraic type: it pattern matches `Bool x` against the
`eqvEquals` value, and then returns `x`. The result of a let-expression
is the expression following the keyword `in`.

To use these functions, insert them into our primitives list:

``` haskell
("car", car),
("cdr", cdr),
("cons", cons),
("eq?", eqv),
("eqv?", eqv),
("equal?", equal)]
```

To compile this code, you need to enable GHC extensions with
`-fglasgow-exts`:

`$ ghc -package parsec -fglasgow-exts -o parser [../code/listing6.4.hs listing6.4.hs]`\
`$ ./parser "(cdr '(a simple test))"`\
`(simple test)`\
`$ ./parser "(car (cdr '(a simple test)))"`\
`simple`\
`$ ./parser "(car '((this is) a test))"`\
`(this is)`\
`$ ./parser "(cons '(this is) 'test)"`\
`((this is) . test)`\
`$ ./parser "(cons '(this is) '())"`\
`((this is))`\
`$ ./parser "(eqv? 1 3)"`\
`#f`\
`$ ./parser "(eqv? 3 3)"`\
`#t`\
`$ ./parser "(eqv? 'atom 'atom)"`\
`#t`


# Write Yourself a Scheme in 48 Hours/Building a REPL

So far, we\'ve been content to evaluate single expressions from the
command line, printing the result and exiting afterwards. This is fine
for a calculator, but isn\'t what most people think of as
\"programming\". We\'d like to be able to define new functions and
variables, and refer to them later. But before we can do this, we need
to build a system that can execute multiple statements without exiting
the program.

Instead of executing a whole program at once, we\'re going to build a
*read-eval-print loop*. This reads in expressions from the console one
at a time and executes them interactively, printing the result after
each expression. Later expressions can reference variables set by
earlier ones (or will be able to, after the next section), letting you
build up libraries of functions.

First, we need to import some additional IO
functions. Add the
following to the top of the program:

``` haskell
import System.IO
```

Next, we define a couple of helper functions to simplify some of our IO
tasks. We\'ll want a function that prints out a string and immediately
flushes the stream; otherwise, output might sit in output buffers and
the user will never see prompts or results.

``` haskell
flushStr :: String -> IO ()
flushStr str = putStr str >> hFlush stdout
```

Then, we create a function that prints out a prompt and reads in a line
of input:

``` haskell
readPrompt :: String -> IO String
readPrompt prompt = flushStr prompt >> getLine
```

Pull the code to parse and evaluate a string and trap the errors out of
main into its own function:

``` haskell
evalString :: String -> IO String
evalString expr = return $ extractValue $ trapError (liftM show $ readExpr expr >>= eval)
```

And write a function that evaluates a string and prints the result:

``` haskell
evalAndPrint :: String -> IO ()
evalAndPrint expr =  evalString expr >>= putStrLn
```

Now it\'s time to tie it all together. We want to read input, perform a
function, and print the output, all in an infinite loop. The built-in
function
`interact`
*almost* does what we want, but doesn\'t loop. If we used the
combination `sequence . repeat . interact`, we\'d get an infinite loop,
but we wouldn\'t be able to break out of it. So we need to roll our own
loop:

``` haskell
until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m ()
until_ pred prompt action = do
   result <- prompt
   if pred result
      then return ()
      else action result >> until_ pred prompt action
```

The underscore after the name is a typical naming convention in Haskell
for monadic functions that repeat but do not return a value. `until_`
takes a predicate that signals when to stop, an action to perform before
the test, and a function-returning-an-action to do to the input. Each of
the latter two is generalized over *any* monad, not just `IO`. That\'s
why we write their types using the type variable `m`, and include the
type constraint `Monad m =>`.

Note also that we can write recursive actions just as we write recursive
functions.

Now that we have all the machinery in place, we can write our REPL
easily:

``` haskell
runRepl :: IO ()
runRepl = until_ (== "quit") (readPrompt "Lisp>>> ") evalAndPrint
```

And change our main function so it either executes a single expression,
or enters the REPL and continues evaluating expressions until we type
`quit`:

``` haskell
main :: IO ()
main = do args <- getArgs
          case length args of
               0 -> runRepl
               1 -> evalAndPrint $ args !! 0
               _ -> putStrLn "Program takes only 0 or 1 argument"
```

Compile and run the program, and try it out:

`$ ghc -package parsec -fglasgow-exts -o lisp [../code/listing7.hs listing7.hs]`\
`$ ./lisp`\
`Lisp>>> (+ 2 3)`\
`5`\
`Lisp>>> (cons this '())`\
`Unrecognized special form: this`\
`Lisp>>> (cons 2 3)`\
`(2 . 3)`\
`Lisp>>> (cons 'this '())`\
`(this)`\
`Lisp>>> quit`\
`$`


# Write Yourself a Scheme in 48 Hours/Adding Variables and Assignment

Finally, we get to the good stuff: variables. A variable lets us save
the result of an expression and refer to it later. In Scheme, a variable
can also be reset to new values, so that its value changes as the
program executes. This presents a complication for Haskell, because the
execution model is built upon functions that return values, but never
change them.

Nevertheless, there are several ways to simulate state in Haskell, all
involving monads. The simplest is probably the state
monad, which lets you
hide arbitrary state within the monad and pass it around behind the
scenes. You specify the state type as a parameter to the monad (e.g. if
a function returns an integer but modifies a list of string pairs, it
would have type `State [(String, String)] Integer`), and access it via
the get and put functions, usually within a do-block. You\'d specify the
initial state via the `runState myStateAction initialList`, which
returns a pair containing the return value and the final state.

Unfortunately, the state monad doesn\'t work well for us, because the
type of data we need to store is fairly complex. For a simple top-level
environment, we could get away with `[(String, LispVal)]`, storing
mappings from variable names to values. However, when we start dealing
with function calls, these mappings become a stack of nested
environments, arbitrarily deep. And when we add closures, environments
might get saved in an arbitrary Function value, and passed around
throughout the program. In fact, they might be saved in a variable and
passed out of the `runState` monad entirely, something we\'re not
allowed to do.

Instead, we use a feature called *state threads*, letting Haskell manage
the aggregate state for us. This lets us treat mutable variables as we
would in any other programming language, using functions to get or set
variables. There are two flavors of state threads: the `ST`
monad
creates a stateful computation that can be executed as a unit, without
the state escaping to the rest of the program. The `IORef`
module
lets you use stateful variables within the IO monad. Since our state has
to be interleaved with IO anyway (it persists between lines in the REPL,
and we will eventually have IO functions within the language itself),
we\'ll be using `IORef`s.

We can start out by importing
`Data.IORef`
and defining a type for our environments:

``` haskell
import Data.IORef

type Env = IORef [(String, IORef LispVal)]
```

This declares an `Env` as an `IORef` holding a list that maps `String`s
to mutable `LispVal`s. We need `IORef`s for both the list itself and for
individual values because there are *two* ways that the program can
mutate the environment. It might use `set!` to change the value of an
individual variable, a change visible to any function that shares that
environment (Scheme allows nested scopes, so a variable in an outer
scope is visible to all inner scopes). Or it might use `define` to add a
new variable, which should be visible on all subsequent statements.

Since `IORef`s can only be used within the IO monad, we\'ll want a
helper action to create an empty environment. We can\'t just use the
empty list `[]` because all accesses to `IORef`s must be sequenced, and
so the type of our null environment is `IO Env` instead of just plain
`Env`:

``` haskell
nullEnv :: IO Env
nullEnv = newIORef []
```

From here, things get a bit more complicated, because we\'ll be
simultaneously dealing with *two* monads. Remember, we also need an
`Error` monad to handle things like unbound variables. The parts that
need IO functionality and the parts that may throw exceptions are
interleaved, so we can\'t just catch all the exceptions and return only
normal values to the IO monad.

Haskell provides a mechanism known as *monad transformers* that lets you
combine the functionality of multiple monads. We\'ll be using one of
these,
`ExceptT`,
which lets us layer error-handling functionality on top of the IO monad.
Our first step is to create a type synonym for our combined monad:

``` haskell
type IOThrowsError = ExceptT LispError IO
```

Like `ThrowsError`, `IOThrowsError` is really a type constructor: we\'ve
left off the last argument, the return type of the function. However,
`ExceptT` takes one more argument than plain old `Either`: we have to
specify the type of monad that we\'re layering our error-handling
functionality over. We\'ve created a monad that may contain IO actions
that throw a `LispError`.

We have a mix of `ThrowsError` and `IOThrowsError` functions, but
actions of different types cannot be contained within the same do-block,
even if they provide essentially the same functionality. Haskell already
provides a mechanism,
lifting,
to bring values of the lower type (`IO`) into the combined monad.
Unfortunately, there\'s no similar support to bring a value of the
untransformed upper type into the combined monad, so we need to write it
ourselves:

``` haskell
liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows (Left err) = throwError err
liftThrows (Right val) = return val
```

This destructures the `Either` type and either re-throws the error type
or returns the ordinary value. Methods in typeclasses resolve based on
the type of the expression, so
`throwError`
and
`return`
(members of
`MonadError`
and
`Monad`,
respectively) take on their `IOThrowsError` definitions. Incidentally,
the type signature provided here is not fully general: if we\'d left it
off, the compiler would have inferred
`liftThrows :: (MonadError m a) => Either e a -> m a`.

We\'ll also want a helper function to run the whole top-level
`IOThrowsError` action, returning an IO action. We can\'t escape from
the IO monad, because a function that performs IO has an effect on the
outside world, and you don\'t want that in a lazily-evaluated pure
function. But you can run the error computation and catch the errors.

``` haskell
runIOThrows :: IOThrowsError String -> IO String
runIOThrows action = runExceptT (trapError action) >>= return . extractValue
```

This uses our previously-defined `trapError` function to take any error
values and convert them to their string representations, then runs the
whole computation via `runExceptT`. The result is passed into
`extractValue` and returned as a value in the IO monad.

Now we\'re ready to return to environment handling. We\'ll start with a
function to determine if a given variable is already bound in the
environment, necessary for proper handling of
`define`:

``` haskell
isBound :: Env -> String -> IO Bool
isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var
```

This first extracts the actual environment value from its `IORef` via
`readIORef`. Then we pass it to lookup to search for the particular
variable we\'re interested in. lookup returns a `Maybe` value, so we
return `False` if that value was `Nothing` and `True` otherwise (we need
to use the
`const`
function because
`maybe`
expects a function to perform on the result and not just a value).
Finally, we use return to lift that value into the IO monad. Since
we\'re just interested in a true/false value, we don\'t need to deal
with the actual `IORef` that lookup returns.

Next, we\'ll want to define a function to retrieve the current value of
a variable:

``` haskell
getVar :: Env -> String -> IOThrowsError LispVal
getVar envRef var  =  do env <- liftIO $ readIORef envRef
                         maybe (throwError $ UnboundVar "Getting an unbound variable" var)
                               (liftIO . readIORef)
                               (lookup var env)
```

Like the previous function, this begins by retrieving the actual
environment from the `IORef`. However, `getVar` uses the `IOThrowsError`
monad, because it also needs to do some error handling. As a result, we
need to use the
`liftIO`
function to lift the `readIORef` action into the combined monad.
Similarly, when we return the value, we use `liftIO . readIORef` to
generate an `IOThrowsError` action that reads the returned `IORef`. We
don\'t need to use `liftIO` to throw an error, however, because
`throwError` is a defined for the `MonadError`
typeclass,
of which `ExceptT` is an instance.

Now we create a function to set values:

``` haskell
setVar :: Env -> String -> LispVal -> IOThrowsError LispVal
setVar envRef var value = do env <- liftIO $ readIORef envRef
                             maybe (throwError $ UnboundVar "Setting an unbound variable" var)
                                   (liftIO . (flip writeIORef value))
                                   (lookup var env)
                             return value
```

Again, we first read the environment out of its `IORef` and run a lookup
on it. This time, however, we want to change the variable instead of
just reading it. The
`writeIORef`
action provides a means for this, but takes its arguments in the wrong
order (ref -\> value instead of value -\> ref). So we use the built-in
function
`flip`
to switch the arguments of `writeIORef` around, and then pass it the
value. Finally, we return the value we just set, for convenience.

We\'ll want a function to handle the special behavior of
`define`,
which sets a variable if already bound or creates a new one if not.
Since we\'ve already defined a function to set values, we can use it in
the former case:

``` haskell
defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal
defineVar envRef var value = do
     alreadyDefined <- liftIO $ isBound envRef var
     if alreadyDefined
        then setVar envRef var value >> return value
        else liftIO $ do
             valueRef <- newIORef value
             env <- readIORef envRef
             writeIORef envRef ((var, valueRef) : env)
             return value
```

It\'s the latter case that\'s interesting, where the variable is
unbound. We create an IO action (via do-notation) that creates a new
`IORef` to hold the new variable, reads the current value of the
environment, then writes a new list back to that variable consisting of
the new (key, variable) pair added to the front of the list. Then we
lift that whole do-block into the `IOThrowsError` monad with `liftIO`.

There\'s one more useful environment function: being able to bind a
whole bunch of variables at once, as happens when a function is invoked.
We might as well build that functionality now, though we won\'t be using
it until the next section:

``` haskell
bindVars :: Env -> [(String, LispVal)] -> IO Env
bindVars envRef bindings = readIORef envRef >>= extendEnv bindings >>= newIORef
     where extendEnv bindings env = liftM (++ env) (mapM addBinding bindings)
           addBinding (var, value) = do ref <- newIORef value
                                        return (var, ref)
```

This is perhaps more complicated than the other functions, since it uses
a monadic pipeline (rather than do-notation) and a pair of helper
functions to do the work. It\'s best to start with the helper functions.
addBinding takes a variable name and value, creates an `IORef` to hold
the new variable, and then returns the name--value pair. `extendEnv`
calls `addBinding` on each member of bindings
(`mapM`)
to create a list of `(String, IORef LispVal)` pairs, and then appends
the current environment to the end of that `(++ env)`. Finally, the
whole function wires these functions up in a pipeline, starting by
reading the existing environment out of its `IORef`, then passing the
result to `extendEnv`, then returning a new `IORef` with the extended
environment.

Now that we have all our environment functions, we need to start using
them in the evaluator. Since Haskell has no global variables, we\'ll
have to thread the environment through the evaluator as a parameter.
While we\'re at it, we might as well add the
`set!`
and
`define`
special forms.

``` haskell
eval :: Env -> LispVal -> IOThrowsError LispVal
eval env val@(String _) = return val
eval env val@(Number _) = return val
eval env val@(Bool _) = return val
eval env (Atom id) = getVar env id
eval env (List [Atom "quote", val]) = return val
eval env (List [Atom "if", pred, conseq, alt]) =
     do result <- eval env pred
        case result of
             Bool False -> eval env alt
             otherwise -> eval env conseq
eval env (List [Atom "set!", Atom var, form]) =
     eval env form >>= setVar env var
eval env (List [Atom "define", Atom var, form]) =
     eval env form >>= defineVar env var
eval env (List (Atom func : args)) = mapM (eval env) args >>= liftThrows . apply func
eval env badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm
```

Since a single environment gets threaded through a whole interactive
session, we need to change a few of our IO functions to take an
environment.

``` haskell
evalAndPrint :: Env -> String -> IO ()
evalAndPrint env expr =  evalString env expr >>= putStrLn

evalString :: Env -> String -> IO String
evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= eval env
```

We need the `runIOThrows` in evalString because the type of the monad
has changed from `ThrowsError` to `IOThrowsError`. Similarly, we need a
`liftThrows` to bring `readExpr` into the `IOThrowsError` monad.

Next, we initialize the environment with a null variable before starting
the program:

``` haskell
runOne :: String -> IO ()
runOne expr = nullEnv >>= flip evalAndPrint expr

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

We\'ve created an additional helper function runOne to handle the
single-expression case, since it\'s now somewhat more involved than just
running `evalAndPrint`. The changes to `runRepl` are a bit more subtle:
notice how we added a function composition operator before evalAndPrint.
That\'s because `evalAndPrint` now takes an additional `Env` parameter,
fed from `nullEnv`. The function composition tells `until_` that instead
of taking plain old `evalAndPrint` as an action, it ought to apply it
first to whatever\'s coming down the monadic pipeline, in this case the
result of `nullEnv`. Thus, the actual function that gets applied to each
line of input is `(evalAndPrint env)`, just as we want it.

Finally, we need to change our main function to call `runOne` instead of
evaluating `evalAndPrint` directly:

``` haskell
main :: IO ()
main = do args <- getArgs
          case length args of
               0 -> runRepl
               1 -> runOne $ args !! 0
               otherwise -> putStrLn "Program takes only 0 or 1 argument"
```

And we can compile and test our program:

`$ ghc -package parsec -o lisp [../code/listing8.hs listing8.hs]`\
`$ ./lisp`\
`Lisp>>> (define x 3)`\
`3`\
`Lisp>>> (+ x 2)`\
`5`\
`Lisp>>> (+ y 2)`\
`Getting an unbound variable: y`\
`Lisp>>> (define y 5)`\
`5`\
`Lisp>>> (+ x (- y 2))`\
`6`\
`Lisp>>> (define str "A string")`\
`"A string"`\
`Lisp>>> (< str "The string")`\
`Invalid type: expected number, found "A string"`\
`Lisp>>> (string<? str "The string")`\
`#t`


# 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:

``` haskell
| 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:

``` haskell
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.

``` haskell
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:

``` haskell
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:

``` haskell
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:

``` haskell
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:

``` haskell
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:

``` haskell
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.

``` haskell
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`


# Write Yourself a Scheme in 48 Hours/Creating IO Primitives

Our Scheme can\'t really communicate with the outside world yet, so it
would be nice if we could give it some I/O functions. Also, it gets
really tedious typing in functions every time we start the interpreter,
so it would be nice to load files of code and execute them.

The first thing we\'ll need is a new constructor for `LispVal`s.
`PrimitiveFunc`s have a specific type signature that doesn\'t include
the IO monad, so they can\'t perform any IO. We want a dedicated
constructor for primitive functions that perform IO:

``` haskell
| IOFunc ([LispVal] -> IOThrowsError LispVal)
```

While we\'re at it, let\'s also define a constructor for the Scheme data
type of a
port.
Most of our IO functions will take one of these to read from or write
to:

``` haskell
| Port Handle
```

A `Handle` is
basically the Haskell notion of a port: it\'s an opaque data type,
returned from `openFile` and similar IO actions, that you can read and
write to.

For completeness, we ought to provide `showVal` methods for the new data
types:

``` haskell
showVal (Port _)   = "<IO port>"
showVal (IOFunc _) = "<IO primitive>"
```

This\'ll let the REPL function properly and not crash when you use a
function that returns a port.

We also need to update apply, so that it can handle `IOFuncs`:

``` haskell
apply (IOFunc func) args = func args
```

We\'ll need to make some minor changes to our parser to support
`load`.
Since Scheme files usually contain several definitions, we need to add a
parser that will support several expressions, separated by whitespace.
And it also needs to handle errors. We can reuse much of the existing
infrastructure by factoring our basic readExpr so that it takes the
actual parser as a parameter:

``` haskell
readOrThrow :: Parser a -> String -> ThrowsError a
readOrThrow parser input = case parse parser "lisp" input of
    Left err  -> throwError $ Parser err
    Right val -> return val

readExpr = readOrThrow parseExpr
readExprList = readOrThrow (endBy parseExpr spaces)
```

Again, think of both `readExpr` and `readExprList` as specializations of
the newly-renamed `readOrThrow`. We\'ll be using `readExpr` in our REPL
to read single expressions; we\'ll be using `readExprList` from within
load to read programs.

Next, we\'ll want a new list of IO primitives, structured just like the
existing primitive list:

``` haskell
ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]
ioPrimitives = [("apply", applyProc),
                ("open-input-file", makePort ReadMode),
                ("open-output-file", makePort WriteMode),
                ("close-input-port", closePort),
                ("close-output-port", closePort),
                ("read", readProc),
                ("write", writeProc),
                ("read-contents", readContents),
                ("read-all", readAll)]
```

The only difference here is in the type signature. Unfortunately, we
can\'t use the existing primitive list because lists cannot contain
elements of different types. We also need to change the definition of
`primitiveBindings` to add our new primitives:

``` haskell
primitiveBindings :: IO Env
primitiveBindings = nullEnv >>= (flip bindVars $ map (makeFunc IOFunc) ioPrimitives
                                               ++ map (makeFunc PrimitiveFunc) primitives)
     where makeFunc constructor (var, func) = (var, constructor func)
```

We\'ve generalized makeFunc to take a constructor argument, and now call
it on the list of `ioPrimitives` in addition to the plain old
primitives.

Now we start defining the actual functions. `applyProc` is a very thin
wrapper around apply, responsible for destructuring the argument list
into the form apply expects:

``` haskell
applyProc :: [LispVal] -> IOThrowsError LispVal
applyProc [func, List args] = apply func args
applyProc (func : args)     = apply func args
```

`makePort` wraps the Haskell function `openFile`, converting it to the
right type and wrapping its return value in the `Port` constructor.
It\'s intended to be partially-applied to the `IOMode`, `ReadMode` for
`open-input-file` and `WriteMode` for `open-output-file`:

``` haskell
makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
```

`closePort` also wraps the equivalent Haskell procedure, this time
`hClose`:

``` haskell
closePort :: [LispVal] -> IOThrowsError LispVal
closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)
closePort _           = return $ Bool False
```

`readProc` (named to avoid a name conflict with the built-in read) wraps
the Haskell `hGetLine` and then sends the result to `parseExpr`, to be
turned into a `LispVal` suitable for Scheme:

``` haskell
readProc :: [LispVal] -> IOThrowsError LispVal
readProc []          = readProc [Port stdin]
readProc [Port port] = (liftIO $ hGetLine port) >>= liftThrows . readExpr
```

Notice how `hGetLine port` is of type `IO String` yet `readExpr` is of
type `String -> ThrowsError LispVal`, so they both need to be converted
(with `liftIO` and `liftThrows`, respectively) to the `IOThrowsError`
monad. Only then can they be piped together with the monadic bind
operator.

`writeProc` converts a `LispVal` to a string and then writes it out on
the specified port:

``` haskell
writeProc :: [LispVal] -> IOThrowsError LispVal
writeProc [obj]            = writeProc [obj, Port stdout]
writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return $ Bool True)
```

We don\'t have to explicitly call show on the object we\'re printing,
because `hPrint` takes a value of type `Show a`. It\'s calling show for
us automatically. This is why we bothered making `LispVal` an instance
of `Show`; otherwise, we wouldn\'t be able to use this automatic
conversion and would have to call `showVal` ourselves. Many other
Haskell functions also take instances of `Show`, so if we\'d extended
this with other IO primitives, it could save us significant labor.

`readContents` reads the whole file into a string in memory. It\'s a
thin wrapper around Haskell\'s `readFile`, again just lifting the IO
action into an `IOThrowsError` action and wrapping it in a `String`
constructor:

``` haskell
readContents :: [LispVal] -> IOThrowsError LispVal
readContents [String filename] = liftM String $ liftIO $ readFile filename
```

The helper function `load` doesn\'t do what Scheme\'s load does (we
handle that later). Rather, it\'s responsible only for reading and
parsing a file full of statements. It\'s used in two places: `readAll`
(which returns a list of values) and `load` (which evaluates those
values as Scheme expressions).

``` haskell
load :: String -> IOThrowsError [LispVal]
load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList
```

`readAll` then just wraps that return value with the `List` constructor:

``` haskell
readAll :: [LispVal] -> IOThrowsError LispVal
readAll [String filename] = liftM List $ load filename
```

Implementing the actual Scheme `load` function is a little tricky,
because `load` can introduce bindings into the local environment. Apply,
however, doesn\'t take an environment argument, and so there\'s no way
for a primitive function (or any function) to do this. We get around
this by implementing `load` as a special form:

``` haskell
eval env (List [Atom "load", String filename]) =
     load filename >>= liftM last . mapM (eval env)
```

Finally, we might as well change our `runOne` function so that instead
of evaluating a single expression from the command line, it takes the
name of a file to execute and runs that as a program. Additional
command-line arguments will get bound into a list `args` within the
Scheme program:

``` haskell
runOne :: [String] -> IO ()
runOne args = do
    env <- primitiveBindings >>= flip bindVars [("args", List $ map String $ drop 1 args)]
    (runIOThrows $ liftM show $ eval env (List [Atom "load", String (args !! 0)]))
        >>= hPutStrLn stderr
```

That\'s a little involved, so let\'s go through it step-by-step. The
first line takes the original primitive bindings, passes that into
`bindVars`, and then adds a variable named `args` that\'s bound to a
`List` containing `String` versions of all but the first argument. (The
first argument is the filename to execute.) Then, it creates a Scheme
form `load "`*`arg1`*`"`, just as if the user had typed it in, and
evaluates it. The result is transformed to a string (remember, we have
to do this before catching errors, because the error handler converts
them to strings and the types must match) and then we run the whole
`IOThrowsError` action. Then we print the result on `stderr`.
(Traditional UNIX conventions hold that `stdout` should be used only for
program output, with any error messages going to `stderr`. In this case,
we\'ll also be printing the return value of the last statement in the
program, which generally has no meaning to anything.)

Then we change main so it uses our new `runOne` function. Since we no
longer need a third clause to handle the wrong number of command-line
arguments, we can simplify it to an if statement:

``` haskell
main :: IO ()
main = do args <- getArgs
          if null args then runRepl else runOne $ args
```


# Write Yourself a Scheme in 48 Hours/Towards a Standard Library

Our Scheme is almost complete now, but it\'s still rather hard to use.
At the very least, we\'d like a library of standard list manipulation
functions that we can use to perform some common computations.

Rather than using a typical Scheme implementation, defining each list
function in terms of a recursion on lists, we\'ll implement two
primitive recursion operators (`fold` and `unfold`) and then define our
whole library based on those. This style is used by the Haskell
Prelude: it
gives you more concise definitions, less room for error, and good
practice using fold to capture iteration.

We\'ll start by defining a few obvious helper functions. `not` and
`null` are defined exactly as you\'d expect it, using if statements:

``` scheme
(define (not x)            (if x #f #t))
(define (null? obj)        (if (eqv? obj '()) #t #f))
```

We can use the varargs feature to define list, which just returns a list
of its arguments:

``` scheme
(define (list . objs)       objs)
```

We also want an `id` function, which just returns its argument
unchanged. This may seem completely useless -- if you already have a
value, why do you need a function to return it? However, several of our
algorithms expect a function that tells us what to do with a given
value. By defining `id`, we let those higher-order functions work even
if we don\'t want to do *anything* with the value.

``` scheme
(define (id obj)           obj)
```

Similarly, it\'d be nice to have a `flip` function, in case we want to
pass in a function that takes its arguments in the wrong order:

``` scheme
(define (flip func)        (lambda (arg1 arg2) (func arg2 arg1)))
```

Finally, we add `curry` and `compose`, which work like their Haskell
equivalents (partial application and the dot operator, respectively).

``` scheme
(define (curry func arg1)  (lambda (arg) (apply func (cons arg1 (list arg)))))
(define (compose f g)      (lambda (arg) (f (apply g arg))))
```

We might as well define some simple library functions that appear in the
Scheme standard:

``` scheme
(define zero?              (curry = 0))
(define positive?          (curry < 0))
(define negative?          (curry > 0))
(define (odd? num)         (= (mod num 2) 1))
(define (even? num)        (= (mod num 2) 0))
```

These are basically done just as you\'d expect them. Note the usage of
curry to define `zero?`, `positive?` and `negative?`. We bind the
variable `zero?` to the function returned by curry, giving us a unary
function that returns true if its argument is equal to zero.

Next, we want to define a fold function that captures the basic pattern
of recursion over a list. The best way to think about fold is to picture
a list in terms of its infix constructors: `[1, 2, 3, 4] = 1:2:3:4:[]`
in Haskell or `(1 . (2 . (3 . (4 . NIL))))` in Scheme. A fold function
replaces every constructor with a binary operation, and replaces `NIL`
with the accumulator. So, for example,
`(fold + 0 '(1 2 3 4)) = (1 + (2 + (3 + (4 + 0))))`.

With that definition, we can write our fold function. Start with a
right-associative version to mimic the above examples:

``` scheme
(define (foldr func end lst)
  (if (null? lst)
      end
      (func (car lst) (foldr func end (cdr lst)))))
```

The structure of this function mimics our definition almost exactly. If
the list is null, replace it with the end value. If not, apply the
function to the car of the list and to the result of folding this
function and end value down the rest of the list. Since the right-hand
operand is folded up first, you end up with a right-associative fold.

We also want a left-associative version. For most associative operations
like `+` and `*,` the two of them are completely equivalent. However,
there is at least one important binary operation that is *not*
associative: cons. For all our list manipulation functions, then, we\'ll
need to deliberately choose between left- and right-associative folds.

``` scheme
(define (foldl func accum lst)
  (if (null? lst)
      accum
      (foldl func (func accum (car lst)) (cdr lst))))
```

This begins the same way as the right-associative version, with the test
for null that returns the accumulator. This time, however, we apply the
function to the accumulator and first element of the list, instead of
applying it to the first element and the result of folding the list.
This means that we process the beginning first, giving us
left-associativity. Once we reach the end of the list, `'()`, we then
return the result that we\'ve been progressively building up.

Note that func takes its arguments in the opposite order from `foldr`.
In `foldr`, the accumulator represents the *rightmost* value to tack
onto the end of the list, after you\'ve finished recursing down it. In
`foldl`, it represents the completed calculation for the *leftmost* part
of the list. In order to preserve our intuitions about commutativity of
operators, it should therefore be the left argument of our operation in
`foldl`, but the right argument in `foldr`.

Once we\'ve got our basic folds, we can define a couple of convenience
names to match typical Scheme usage:

``` scheme
(define fold foldl)
(define reduce foldr)
```

These are just new variables bound to the existing functions: they
don\'t define new functions. Most Schemes call `fold` \"`reduce`\" or
plain old \"`fold`\", and don\'t make the distinction between `foldl`
and `foldr`. We define it to be `foldl`, which happens to be
tail-recursive and hence runs more efficiently than `foldr` (it doesn\'t
have to recurse all the way down to the end of the list before it starts
building up the computation). Not all operations are associative,
however; we\'ll see some cases later where we *have* to use `foldr` to
get the right result.

Next, we want to define a function that is the opposite of `fold`. Given
a unary function, an initial value, and a unary predicate, it continues
applying the function to the last value until the predicate is true,
building up a list as it goes along.

``` scheme
(define (unfold func init pred)
  (if (pred init)
      (cons init '())
      (cons init (unfold func (func init) pred))))
```

As usual, our function structure basically matches the definition. If
the predicate is true, then we cons a `'()` onto the last value,
terminating the list. Otherwise, cons the result of unfolding the next
value `(func init)` onto the current value.

In academic functional programming literature, folds are often called
*catamorphisms*, unfolds are often called *anamorphisms*, and the
combinations of the two are often called *hylomorphisms*. They\'re
interesting because *any for-each loop can be represented as a
catamorphism*. To convert from a loop to a foldl, package up all mutable
variables in the loop into a data structure (records work well for this,
but you can also use an algebraic data type or a list). The initial
state becomes the accumulator; the loop body becomes a function with the
loop variables as its first argument and the iteration variable as its
second; and the list becomes, well, the list. The result of the fold
function is the new state of all the mutable variables.

Similarly, *every for-loop (without early exits) can be represented as a
hylomorphism*. The initialization, termination, and step conditions of a
for-loop define an anamorphism that builds up a list of values for the
iteration variable to take. Then, you can treat that as a for-each loop
and use a catamorphism to break it down into whatever state you wish to
modify.

Let\'s go through a couple examples. We\'ll start with typical `sum`,
`product`, `and` & `or` functions:

``` scheme
(define (sum . lst)         (fold + 0 lst))
(define (product . lst)     (fold * 1 lst))
(define (and . lst)         (fold && #t lst))
(define (or . lst)          (fold || #f lst))
```

These all follow from the definitions:

-   `(sum 1 2 3 4) = 1 + 2 + 3 + 4 + 0 = (fold + 0 '(1 . (2 . (3 . (4 . NIL)))))`
-   `(product 1 2 3 4) = 1 * 2 * 3 * 4 * 1 = (fold * 1 '(1 . (2 . (3 . (4 . NIL)))))`
-   `(and #t #t #f) = #t && #t && #f && #t = (fold && #t '(#t . (#t . (#f . NIL))))`
-   `(or #t #t #f) = #t || #t || #f || #f = (fold || #f '(#t . (#t . (#f . NIL))))`

Since all of these operators are associative, it doesn\'t matter whether
we use `foldr` or `foldl`. We replace the cons constructor with the
operator, and the nil constructor with the identity element for that
operator.

Next, let\'s try some more complicated operators. `max` and `min` find
the maximum and minimum of their arguments, respectively:

``` scheme
(define (max first . rest) (fold (lambda (old new) (if (> old new) old new)) first rest))
(define (min first . rest) (fold (lambda (old new) (if (< old new) old new)) first rest))
```

It\'s not immediately obvious what operation to fold over the list,
because none of the built-ins quite qualify. Instead, think back to fold
as a representation of a foreach loop. The accumulator represents any
state we\'ve maintained over previous iterations of the loop, so we\'ll
want it to be the maximum value we\'ve found so far. That gives us our
initialization value: we want to start off with the leftmost variable in
the list (since we\'re doing a `foldl`). Now recall that the result of
the operation becomes the new accumulator at each step, and we\'ve got
our function. If the previous value is greater, keep it. If the new
value is greater, or they\'re equal, return the new value. Reverse the
operation for `min`.

How about `length`? We know that we can find the length of a list by
counting down it, but how do we translate that into a fold?

``` scheme
(define (length lst)        (fold (lambda (x y) (+ x 1)) 0 lst))
```

Again, think in terms of its definition as a loop. The accumulator
starts off at 0 and gets incremented by 1 with each iteration. That
gives us both our initialization value, 0, and our function,
`(lambda (x y) (+ x 1))`. Another way to look at this is \"The length of
a list is 1 + the length of the sublist to its left\".

Let\'s try something a bit trickier: `reverse`.

``` scheme
(define (reverse lst)       (fold (flip cons) '() lst))
```

The function here is fairly obvious: if you want to reverse two `cons`
cells, you can just `flip cons` so it takes its arguments in the
opposite order. However, there\'s a bit of subtlety at work. Ordinary
lists are *right* associative:
`(1 2 3 4) = (1 . (2 . (3 . (4 . NIL))))`. If you want to reverse this,
you need your fold to be *left* associative:
`(reverse '(1 2 3 4)) = (4 . (3 . (2 . (1 . NIL))))`. Try it with a
`foldr` instead of a foldl and see what you get.

There\'s a whole family of `member` and `assoc` functions, all of which
can be represented with folds. The particular lambda expression is
fairly complicated though, so let\'s factor it out:

``` scheme
(define (mem-helper pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc)))
(define (memq obj lst)       (fold (mem-helper (curry eq? obj) id) #f lst))
(define (memv obj lst)       (fold (mem-helper (curry eqv? obj) id) #f lst))
(define (member obj lst)     (fold (mem-helper (curry equal? obj) id) #f lst))
(define (assq obj alist)     (fold (mem-helper (curry eq? obj) car) #f alist))
(define (assv obj alist)     (fold (mem-helper (curry eqv? obj) car) #f alist))
(define (assoc obj alist)    (fold (mem-helper (curry equal? obj) car) #f alist))
```

The helper function is parameterized by the predicate to use and the
operation to apply to the result if found. Its accumulator represents
the first value found so far: it starts out with `#f` and takes on the
first value that satisfies its predicate. We avoid finding subsequent
values by testing for a non-`#f` value and returning the existing
accumulator if it\'s already set. We also provide an operation that will
be applied to the next value each time the predicate tests: this lets us
customize `mem-helper` to check the value itself (for `member`) or only
the key of the value (for `assoc`).

The rest of the functions are just various combinations of `eq?`,
`eqv?`, `equal?` and `id`, `car`, folded over the list with an initial
value of `#f`.

Next, let\'s define the functions `map` and `filter`. `map` applies a
function to every element of a list, returning a new list with the
transformed values:

``` scheme
(define (map func lst)      (foldr (lambda (x y) (cons (func x) y)) '() lst))
```

Remember that `foldr`\'s function takes its arguments in the opposite
order as `fold`, with the current value on the left. Map\'s lambda
applies the function to the current value, then conses it with the rest
of the mapped list, represented by the right-hand argument. It\'s
essentially replacing every infix cons constructor with one that conses,
but also applies the function to its left-side argument.

`filter` keeps only the elements of a list that satisfy a predicate,
dropping all others:

``` scheme
(define (filter pred lst)   (foldr (lambda (x y) (if (pred x) (cons x y) y)) '() lst))
```

This works by testing the current value against the predicate. If it\'s
true, replacing cons with `cons`, i.e., don\'t do anything. If it\'s
false, drop the `cons` and just return the rest of the list. This
eliminates all the elements that don\'t satisfy the predicate, consing
up a new list that includes only the ones that do.

We can use the standard library by starting up our Lisp interpreter and
typing `(load "stdlib.scm")`:

`$ ./lisp`\
`Lisp>>> (load "stdlib.scm")`\
`(lambda ("pred" . lst) ...)`\
`Lisp>>> (map (curry + 2) '(1 2 3 4))`\
`(3 4 5 6)`\
`Lisp>>> (filter even? '(1 2 3 4))`\
`(2 4)`\
`Lisp>>> quit`

There are many other useful functions that could go into the standard
library, including `list-tail`, `list-ref`, append, and various
string-manipulation functions. Try implementing them as folds. Remember,
the key to successful fold programming is thinking only in terms of what
happens on each iteration. Fold captures the pattern of recursion down a
list, and recursive problems are best solved by working one step at a
time.


# Write Yourself a Scheme in 48 Hours/Conclusion

You now have a working Scheme interpreter that implements a large chunk
of the standard, including functions, lambdas, lexical scoping, symbols,
strings, integers, list manipulation, and assignment. You can use it
interactively, with a REPL, or in batch mode, running script files. You
can write libraries of Scheme functions and either include them in
programs or load them into the interactive interpreter. With a little
text processing via awk or sed, you can format the output of UNIX
commands as parenthesized Lisp lists, read them into a Scheme program,
and use this interpreter for shell scripting.

There are still a number of features you could add to this interpreter.
Hygienic macros let you perform transformations on the source code
before it\'s executed. They\'re a very convenient feature for adding new
language features, and several standard parts of Scheme (such as
let-bindings and additional control flow features) are defined in terms
of them. Section
4.3
of R5RS defines the macro system\'s syntax and semantics, and there is a
whole
collection
of papers on implementation. Basically, you\'d want to intersperse a
function between readExpr and eval that takes a form and a macro
environment, looks for transformer keywords, and then transforms them
according to the rules of the pattern language, rewriting variables as
necessarily.

Continuations are a way of capturing \"the rest of the computation\",
saving it, and perhaps executing it more than once. Using them, you can
implement just about every control flow feature in every major
programming language. The easiest way to implement continuations is to
transform the program into continuation-passing
style,
so that eval takes an additional continuation argument and calls it,
instead of returning a result. This parameter gets threaded through all
recursive calls to eval, but is only manipulated when evaluating a call
to call-with-current-continuation.

Dynamic-wind could be implemented by keeping a stack of functions to
execute when leaving the current continuation and storing (inside the
continuation data type) a stack of functions to execute when resuming
the continuation.

If you\'re just interested in learning more Haskell, there are a large
number of libraries that may help:

-   For webapps:
    WASH,
    a monadic web framework
-   For databases:
    haskelldb, a library
    that wraps SQL as a set of Haskell functions, giving you all the
    type-safety of the language when querying the database
-   For GUI programming: Fudgets
    and wxHaskell. wxHaskell is
    more of a conventional MVC GUI library, while Fudgets includes a lot
    of new research about how to represent GUIs in functional
    programming languages
-   For concurrency: Software Transactional
    Memory,
    described in the paper Composable Memory
    Transactions
-   For networking: GHC\'s Networking
    libraries

This should give you a starting point for further investigations into
the language. Happy hacking!

## Acknowledgements

Thanks to Ketil Malde, Pete Kazmier, and Brock for sending in questions
and suggestions about this tutorial. Additional comments,
clarifications, and corrections should go on the discussion
page of
this tutorial.


# Write Yourself a Scheme in 48 Hours/Answers

 | author   =
 | section  = Answers
 | previous = [[../Conclusion|Conclusion]]
 | next     =
 | notes    =
}}
```
\_\_TOC\_\_

# Chapter 1

### Exercise 1

`main :: IO ()`\
`main = do args <- getArgs`\
`          putStrLn ("Hello, " ++ args!!0 ++ " " ++ args!!1)`

### Exercise 2

`main :: IO ()`\
`main = do args <- getArgs`\
`          print ((read $ args!!0) + (read $ args!!1))`

The `$` operator reduces the number of parentheses needed here.
Alternatively you could write the function applications as
`read (args!!0)`.

### Exercise 3

`main :: IO ()`\
`main = do putStrLn "What do they call thee at home?"`\
`          name <- getLine`\
`          putStrLn ("Ey up " ++ name)`

# Chapter 2

## Section 3 - Parsing

### Exercise 1

#### Part 1

`parseNumber :: Parser LispVal`\
`parseNumber = do x <- many1 digit`\
`                (return . Number . read) x`

#### Part 2

In order to answer this question, you need to do a bit of detective
work! It is helpful to read up on do
notation.
Using the information there, we can mechanically transform the above
answer into the following.

`parseNumber = many1 digit >>= \x -> (return . Number . read) x`

This can be cleaned up into the following:

`parseNumber = many1 digit >>= return . Number . read`

### Exercise 2

We need to create a new parser action that accepts a backslash followed
by either another backslash or a doublequote. This action needs to
return only the second character.

`escapedChars :: Parser Char`\
`escapedChars = do char '\\' -- a backslash`\
`                  x <- oneOf "\\\"" -- either backslash or doublequote`\
`                  return x -- return the escaped character`

Once that is done, we need to make some changes to parseString.

`parseString :: Parser LispVal`\
`parseString = do char '"'`\
`                 x <- many $ escapedChars <|> noneOf "\"\\"`\
`                 char '"'`\
`                 return $ String x`

### Exercise 3

`escapedChars :: Parser Char`\
`escapedChars = do char '\\' `\
`                  x <- oneOf "\\\"nrt" `\
`                  return $ case x of `\
`                    '\\' -> x`\
`                    '"'  -> x`\
`                    'n'  -> '\n'`\
`                    'r'  -> '\r'`\
`                    't'  -> '\t'`

### Exercise 4

First, it is necessary to change the definition of symbol.

`symbol :: Parser Char`\
`symbol = oneOf "!$%&|*+-/:<=>?@^_~"`

This means that it is no longer possible to begin an atom with the hash
character. This necessitates a different way of parsing #t and #f.

`parseBool :: Parser LispVal`\
`parseBool = do`\
`    char '#'`\
`    (char 't' >> return (Bool True)) <|> (char 'f' >> return (Bool False))`

This in turn requires us to make changes to parseExpr.

`parseExpr :: Parser LispVal`\
`parseExpr = parseAtom`\
`        <|> parseString`\
`        <|> parseNumber`\
`        <|> parseBool`

parseNumber need to be changed to the following.

`parseNumber :: Parser LispVal`\
`parseNumber = parseDecimal1 <|> parseDecimal2 <|> parseHex <|> parseOct <|> parseBin`

And the following new functions need to be added.

`parseDecimal1 :: Parser LispVal`\
`parseDecimal1 = many1 digit >>= (return . Number . read)`

`parseDecimal2 :: Parser LispVal`\
`parseDecimal2 = do try $ string "#d"`\
`                   x <- many1 digit`\
`                   (return . Number . read) x`

`parseHex :: Parser LispVal`\
`parseHex = do try $ string "#x"`\
`              x <- many1 hexDigit`\
`              return $ Number (hex2dig x)`

`parseOct :: Parser LispVal`\
`parseOct = do try $ string "#o"`\
`              x <- many1 octDigit`\
`              return $ Number (oct2dig x)`

`parseBin :: Parser LispVal`\
`parseBin = do try $ string "#b"`\
`              x <- many1 (oneOf "10")`\
`              return $ Number (bin2dig x)`

`oct2dig x = fst $ readOct x !! 0`\
`hex2dig x = fst $ readHex x !! 0`\
`bin2dig  = bin2dig' 0`\
`bin2dig' digint "" = digint`\
`bin2dig' digint (x:xs) = let old = 2 * digint + (if x == '0' then 0 else 1) in`\
`                         bin2dig' old xs`

Import the *Numeric* module to use the readOct and readHex functions.

### Exercise 5

`data LispVal = Atom String`\
`             | List [LispVal]`\
`             | DottedList [LispVal] LispVal`\
`             | Number Integer`\
`             | String String`\
`             | Bool Bool`\
`             | Character Char`

`parseCharacter :: Parser LispVal`\
`parseCharacter = do`\
` try $ string "#\\"`\
` value <- try (string "newline" <|> string "space") `\
`         <|> do { x <- anyChar; notFollowedBy alphaNum ; return [x] }`\
`  return $ Character $ case value of`\
`    "space" -> ' '`\
`    "newline" -> '\n'`\
`    otherwise -> (value !! 0)`

The combination of anyChar and notFollowedBy ensure that only a single
character is read.

Note that this does not actually conform to the standard; as it stands,
\"space\" and \"newline\" must be entirely lowercase; the standard
states that they should be case insensitive.

`parseExpr :: Parser LispVal`\
`parseExpr = parseAtom`\
`        <|> parseString`\
`        <|> try parseNumber -- we need the 'try' because `\
`        <|> try parseBool -- these can all start with the hash char`\
`        <|> try parseCharacter`

### Exercise 6

A possible solution for floating point numbers:

` parseFloat :: Parser LispVal`\
` parseFloat = do x <- many1 digit`\
`                 char '.'`\
`                 y <- many1 digit`\
`                 return $ Float (fst.head$readFloat (x++"."++y))`

Furthermore, add

` try parseFloat`

*before* parseNumber in parseExpr and the line

` | Float Double`

to the LispVal type.

### Exercise 7

**Ratio**, using Haskell\'s Rational type:

` parseRatio :: Parser LispVal`\
` parseRatio = do x <- many1 digit`\
`                 char '/'`\
`                 y <- many1 digit`\
`                 return $ Ratio ((read x) % (read y))`

Additionally, import the *Data.Ratio* module, add

` try parseRatio`

*before* parseNumber in parseExpr and the line

` | Ratio Rational`

to the LispVal type.

**Real** is already implemented in the Float type from Exercise 6,
unless I\'m mistaken.

**Complex** using Haskell\'s Complex type:

` toDouble :: LispVal -> Double`\
` toDouble(Float f) = realToFrac f`\
` toDouble(Number n) = fromIntegral n`

` parseComplex :: Parser LispVal`\
` parseComplex = do x <- (try parseFloat <|> parseDecimal)`\
`                   char '+' `\
`                   y <- (try parseFloat <|> parseDecimal)`\
`                   char 'i' `\
`                   return $ Complex (toDouble x :+ toDouble y)`

As before, import the *Data.Complex* module, add

` try parseComplex`

*before* parseNumber and parseFloat in parseExpr and the line

`  | Complex (Complex Double)`

to the LispVal type.

## Section 4 - Recursive Parsers: Adding lists, dotted lists, and quoted datums

### Exercise 1

These two are analogous to parseQuoted:

` parseQuasiQuoted :: Parser LispVal`\
` parseQuasiQuoted = do`\
``      char '`' ``\
`     x <- parseExpr`\
`     return $ List [Atom "quasiquote", x]`

` parseUnQuote :: Parser LispVal`\
` parseUnQuote = do`\
`     char ','`\
`     x <- parseExpr`\
`     return $ List [Atom "unquote", x]`

` parseUnQuoteSplicing :: Parser LispVal`\
` parseUnQuoteSplicing = do`\
`     char ','`\
`     char '@'`\
`     x <- parseExpr`\
`     return $ List [Atom "unquote-splicing", x]`

Also add

`       <|> parseQuasiQuoted`\
`       <|> parseUnQuote`\
`       <|> parseUnQuoteSplicing`

to parseExpr.

### Exercise 2

I chose to go with Arrays as described in
Data.Array
and used list-array conversions for array construction.

` parseVector :: Parser LispVal`\
` parseVector = do arrayValues <- sepBy parseExpr spaces`\
`                  return $ Vector (listArray (0,(length arrayValues - 1)) arrayValues)`

In order to use this, import *Data.Array* and add the following to the
LispVal type:

`            | Vector (Array Int LispVal)`

Add the following lines to parseExpr; *before* the parser for Lists and
DottedLists.

`       <|> try (do string "#("`\
`                   x <- parseVector`\
`                   char ')'`\
`                   return x)`

### Exercise 3

This took a fair amount of fiddling with `sepBy`, `endBy` and friends. I
started by getting the `(. degenerate)` dotted list to work and then
went from there. This code tolerates trailing and leading spaces.

`parseAnyList :: Parser LispVal`\
`parseAnyList = do`\
`  P.char '('`\
`  optionalSpaces`\
`  head <- P.sepEndBy parseExpr spaces`\
`  tail <- (P.char '.' >> spaces >> parseExpr) <|> return (Nil ())`\
`  optionalSpaces`\
`  P.char ')'`\
`  return $ case tail of`\
`    (Nil ()) -> List head`\
`    otherwise -> DottedList head tail`

Another implementation using more advanced functions from the Parsec
library. `spaces` is the one from this tutorial.

`parseList :: Parser LispVal`\
`parseList = between beg end parseList1`\
`           where beg = (char '(' >> skipMany space)`\
`                 end = (skipMany space >> char ')')`

`parseList1 :: Parser LispVal`\
`parseList1 = do list <- sepEndBy parseExpr spaces`\
`               maybeDatum <- optionMaybe (char '.' >> spaces >> parseExpr)`\
`               return $ case maybeDatum of`\
`                  Nothing -> List list`\
`                  Just datum  -> DottedList list datum`

Alternative solution. `spaces` is the spaces from Parsec and `spaces1`
is the spaces from this tutorial.

`parseList :: Parser LispVal`\
`parseList = do char '(' >> spaces`\
``                head <- parseExpr `sepEndBy` spaces1 ``\
`               do char '.' >> spaces1`\
`                  tail <- parseExpr`\
`                  spaces >> char ')'`\
`                  return $ DottedList head tail`\
`                <|> (spaces >> char ')' >> (return $ List head))`

# Chapter 3

### Exercise 1

Here is one way of adding a few of them.

`primitives :: [(String , [LispVal] -> LispVal)]`\
`primitives = [("+" , numericBinop (+)) ,`\
`              ("-" , numericBinop (-)) ,`\
`              ("*" , numericBinop (*)) ,`\
`              ("/" , numericBinop div) ,`\
`              ("mod" , numericBinop mod) ,`\
`              ("quotient" , numericBinop quot) ,`\
`              ("remainder" , numericBinop rem) ,`\
`              ("symbol?" , unaryOp symbolp) ,`\
`              ("string?" , unaryOp stringp) ,`\
`              ("number?" , unaryOp numberp) ,`\
`              ("bool?", unaryOp boolp) ,`\
`              ("list?" , unaryOp listp)]`

`unaryOp :: (LispVal -> LispVal) -> [LispVal] -> LispVal`\
`unaryOp f [v] = f v`

`symbolp, numberp, stringp, boolp, listp :: LispVal -> LispVal`\
`symbolp (Atom _)   = Bool True`\
`symbolp _          = Bool False`\
`numberp (Number _) = Bool True`\
`numberp _          = Bool False`\
`stringp (String _) = Bool True`\
`stringp _          = Bool False`\
`boolp   (Bool _)   = Bool True`\
`boolp   _          = Bool False`\
`listp   (List _)   = Bool True`\
`listp   (DottedList _ _) = Bool False`\
`listp   _          = Bool False`

### Exercise 2

`unpackNum :: LispVal -> Integer`\
`unpackNum (Number n) = n`\
`unpackNum _          = 0`

### Exercise 3

Add symbol-\>string and string-\>symbol to the list of primitives, then:

`symbol2string, string2symbol :: LispVal -> LispVal`\
`symbol2string (Atom s)   = String s`\
`symbol2string _          = String ""`\
`string2symbol (String s) = Atom s`\
`string2symbol _          = Atom ""`

This doesn\'t deal well with bad input, which is covered later.

# Chapter 5

### Exercise 1

`eval env (List [Atom "if", pred, conseq, alt]) = do `\
`   result <- eval env pred`\
`   case result of`\
`     Bool False -> eval env alt`\
`     Bool True  -> eval env conseq`\
`     _          -> throwError $ TypeMismatch "bool" pred`

### Exercise 2

Define a helper function that takes the equal/eqv function as an
argument:

` eqvList :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal`\
` eqvList eqvFunc [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) && `\
`                                                     (all eqvPair $ zip arg1 arg2)`\
`       where eqvPair (x1, x2) = case eqvFunc [x1, x2] of`\
`                                     Left err -> False`\
`                                     Right (Bool val) -> val`

Now adjust the eqv clause:

` eqv listPair@[List _, List _] = eqvList eqv listPair`

And add clauses for List and DottedList to the equal function:

` equal :: [LispVal] -> ThrowsError LispVal`\
` equal listPair@[List _, List _] = eqvList equal listPair`\
` equal [(DottedList xs x), (DottedList ys y)] = equal [List $ xs ++ [x], List $ ys ++ [y]]`\
` equal [arg1, arg2] = do`\
`     primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)`\
`                        [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]`\
`     eqvEquals <- eqv [arg1, arg2]`\
`     return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)`\
` equal badArgList = throwError $ NumArgs 2 badArgList`

### Exercise 3

#### cond

Room for improvement here!

`eval (List ((Atom "cond"):cs))              = do `\
`  b <- (liftM (take 1 . dropWhile f) $ mapM condClause cs) >>= cdr   `\
`  car [b] >>= eval `\
`    where condClause (List [p,b]) = do q <- eval p`\
`                                       case q of`\
`                                         Bool _ -> return $ List [q,b]`\
`                                         _      -> throwError $ TypeMismatch "bool" q `\
`          condClause v            = throwError $ TypeMismatch "(pred body)" v `\
`          f                       = \(List [p,b]) -> case p of `\
`                                                       (Bool False) -> True`\
`                                                       _            -> False`

Another approach:

`eval env (List (Atom "cond" : expr : rest)) = do`\
`    eval' expr rest`\
`    where eval' (List [cond, value]) (x : xs) = do`\
`              result <- eval env cond`\
`              case result of`\
`                   Bool False -> eval' x xs`\
`                   Bool True  -> eval env value`\
`                   otherwise  -> throwError $ TypeMismatch "boolean" cond`\
`          eval' (List [Atom "else", value]) [] = do`\
`               eval env value`\
`          eval' (List [cond, value]) [] = do`\
`              result <- eval env cond`\
`              case result of`\
`                   Bool True  -> eval env value`\
`                   otherwise  -> throwError $ TypeMismatch "boolean" cond`

Yet another approach, piggy-backing off of the already-implemented if:

`eval form@(List (Atom "cond" : clauses)) =`\
`  if null clauses`\
`  then throwError $ BadSpecialForm "no true clause in cond expression: " form`\
`  else case head clauses of`\
`    List [Atom "else", expr] -> eval expr`\
`    List [test, expr]        -> eval $ List [Atom "if",`\
`                                             test,`\
`                                             expr,`\
`                                             List (Atom "cond" : tail clauses)]`\
`    _ -> throwError $ BadSpecialForm "ill-formed cond expression: " form`

Yet another approach

` eval (List ((Atom "cond") : alts)) = cond alts`

` cond :: [LispVal] -> ThrowsError LispVal`\
` cond ((List (Atom "else" : value : [])) : []) = eval value`\
` cond ((List (condition : value : [])) : alts) = do`\
`     result <- eval condition`\
`     boolResult :: Bool <- unpackBool result`\
`     if boolResult then eval value`\
`                   else cond alts`\
` cond ((List a) : _) = throwError $ NumArgs 2 a`\
` cond (a : _) = throwError $ NumArgs 2 [a]`\
` cond _ = throwError $ Default "Not viable alternative in cond"`

#### case

This solution requires LispVal to have a deriving (Eq) clause, in order
to use the \`elem\` function.

`eval form@(List (Atom "case" : key : clauses)) =`\
`  if null clauses`\
`  then throwError $ BadSpecialForm "no true clause in case expression: " form`\
`  else case head clauses of`\
`    List (Atom "else" : exprs) -> mapM eval exprs >>= return . last`\
`    List ((List datums) : exprs) -> do`\
`      result <- eval key`\
`      equality <- mapM (\x -> eqv [result, x]) datums`\
``       if Boolean True `elem` equality ``\
`        then mapM eval exprs >>= return . last`\
`        else eval $ List (Atom "case" : key : tail clauses)`\
`    _                     -> throwError $ BadSpecialForm "ill-formed case expression: " form`

### Exercise 4

Let\'s add string-length and string-ref:

`   primitives = [...`\
`                 ("string-length", stringLen),                                     │`\
`                 ("string-ref", stringRef),`\
`                 ...]`

`   stringLen :: [LispVal] -> ThrowsError LispVal`\
`   stringLen [(String s)] = Right $ Number $ fromIntegral $ length s`\
`   stringLen [notString]  = throwError $ TypeMismatch "string" notString`\
`   stringLen badArgList   = throwError $ NumArgs 1 badArgList`

`   stringRef :: [LispVal] -> ThrowsError LispVal`\
`   stringRef [(String s), (Number k)]`\
`       | length s < k' + 1 = throwError $ Default "Out of bound error"`\
`       | otherwise         = Right $ String $ [s !! k']`\
`       where k' = fromIntegral k`\
`   stringRef [(String s), notNum] = throwError $ TypeMismatch "number" notNum`\
`   stringRef [notString, _]       = throwError $ TypeMismatch "string" notString`\
`   stringRef badArgList           = throwError $ NumArgs 2 badArgList`