Write Yourself a Scheme in 48 Hours/Answers

=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.

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

=Chapter 2=

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.

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,   and friends. I started by getting the  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. 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. is the spaces from Parsec and  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

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