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:
("=", 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 2 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:
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 arg may throw a type mismatch, we have to unpack them sequentially, in a doblock (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 LispVals 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:
numBoolBinop = boolBinop unpackNum strBoolBinop = boolBinop unpackStr boolBoolBinop = boolBinop unpackBool
We haven't told Haskell how to unpack strings from LispVals 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.
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:
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:
debian:/home/jdtang/haskell_tutorial/code# ghc package parsec o simple_parser [../code/listing6.1.hs listing6.1.hs] debian:/home/jdtang/haskell_tutorial/code# ./simple_parser "(< 2 3)" #t debian:/home/jdtang/haskell_tutorial/code# ./simple_parser "(> 2 3)" #f debian:/home/jdtang/haskell_tutorial/code# ./simple_parser "(>= 3 3)" #t debian:/home/jdtang/haskell_tutorial/code# ./simple_parser "(string=? \"test\" \"test\")" #t debian:/home/jdtang/haskell_tutorial/code# ./simple_parser "(string<? \"abc\" \"bba\")" #t
Conditionals: Pattern Matching 2
Now, we'll proceed to adding an ifclause to our evaluator. As with standard Scheme, our evaluator considers #f to be false and any other value to be true:
eval (List [Atom "if", pred, conseq, alt]) = do result < eval pred case result of Bool False > eval alt otherwise > eval conseq
This is another example of nested patternmatching. Here, we're looking for a 4element 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:
debian:/home/jdtang/haskell_tutorial/code# ghc package parsec o simple_parser [../code/listing6.2.hs listing6.2.hs] debian:/home/jdtang/haskell_tutorial/code# ./simple_parser "(if (> 2 3) \"no\" \"yes\")" "yes" debian:/home/jdtang/haskell_tutorial/code# ./simple_parser "(if (= 3 3) (+ 2 3 ( 5 1)) \"unequal\")" 9
List Primitives: car, cdr, and cons
For good measure, lets also add in the basic listhandling 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 Sexpressions:
 (car '(a b c)) = a
 (car '(a)) = a
 (car '(a b . c)) = a
 (car 'a) = error (not a list)
 (car 'a 'b) = error (car takes only 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:
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:
 (cdr '(a b c)) = (b c)
 (cdr '(a b)) = (b)
 (cdr '(a)) = NIL
 (cdr '(a . b)) = b
 (cdr '(a b . c)) = (b . c)
 (cdr 'a) = error (not list)
 (cdr 'a 'b) = error (too many args)
We can represent the first 3 cases with a single clause. Our parser represents '() as List [], and when you patternmatch (x : xs) against [x], xs is bound to []. The other ones translate to separate clauses:
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 casebycase. If you cons together anything with Nil, you end up with a oneitem list, the Nil serving as a terminator:
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:
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:
cons [x, DottedList xs xlast] = return $ DottedList (x : xs) xlast
If you cons together two nonlists, 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.
cons [x1, x2] = return $ DottedList [x1] x2
Finally, attempting to cons together more or less than 2 arguments is an error:
cons badArgList = throwError $ NumArgs 2 badArgList
Our last step is to implement eqv?. Scheme offers 3 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?.
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 selfexplanatory, the exception being the one for two Lists. This, after checking to make sure the lists are the same length, zips 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: fglasgowexts
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:
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 Unpackers 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 LispVals are equal when it unpacks them:
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 patternmatching to retrieve the actual function, we enter a doblock for the ThrowsError monad. This retrieves the Haskell values of the two LispVals, 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:
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 partiallyapplied (unpackEquals arg1 arg2) over it. This gives a list of Bools, 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 dottedlist (though this introduces a bug; see exercise #2 in this section).
Finally, equal? ors 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 letexpression is the expression following the keyword "in".
To use these functions, insert them into our primitives list:
("car", car), ("cdr", cdr), ("cons", cons), ("eq?", eqv), ("eqv?", eqv), ("equal?", equal)]
To compile this code, you need to enable GHC extensions with fglasgowexts:
debian:/home/jdtang/haskell_tutorial/code$ ghc package parsec fglasgowexts o parser [../code/listing6.4.hs listing6.4.hs] debian:/home/jdtang/haskell_tutorial/code# ./parser "(cdr '(a simple test))" (simple test) debian:/home/jdtang/haskell_tutorial/code# ./parser "(car (cdr '(a simple test)))" simple debian:/home/jdtang/haskell_tutorial/code# ./parser "(car '((this is) a test))" (this is) debian:/home/jdtang/haskell_tutorial/code# ./parser "(cons '(this is) 'test)" ((this is) . test) debian:/home/jdtang/haskell_tutorial/code# ./parser "(cons '(this is) '())" ((this is)) debian:/home/jdtang/haskell_tutorial/code# ./parser "(eqv? 1 3)" #f debian:/home/jdtang/haskell_tutorial/code# ./parser "(eqv? 3 3)" #t debian:/home/jdtang/haskell_tutorial/code# ./parser "(eqv? 'atom 'atom)" #t
Exercises 

