001 module Main where
002 import Monad
003 import Control.Monad.Error
004 import System.Environment
005 import IO hiding (try)
006 import Data.IORef
007 import Text.ParserCombinators.Parsec hiding (spaces)
008
009 symbol :: Parser Char
010 symbol = oneOf "!$%&|*+-/:<=?>@^_~#"
011
012 data LispVal = Atom String
013              | List [LispVal]
014              | DottedList [LispVal] LispVal
015              | Number Integer
016              | String String
017              | Bool Bool
018              | PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
019              | Func {params :: [String], vararg :: (Maybe String),
020                     body :: [LispVal], closure :: Env}
021              | IOFunc ([LispVal] -> IOThrowsError LispVal)
022              | Port Handle
023
024 data LispError = NumArgs Integer [LispVal]
025                | TypeMismatch String LispVal
026                | Parser ParseError
027                | BadSpecialForm String LispVal
028                | NotFunction String String
029                | UnboundVar String String
030                | Default String
031
032 spaces :: Parser ()
033 spaces = skipMany1 space
034
035 parseString :: Parser LispVal
036 parseString = do char '"'
037                  x <- many (noneOf "\"")
038                  char '"'
039                  return $ String x
040
041 parseAtom :: Parser LispVal
042 parseAtom = do first <- letter <|> symbol
043                rest <- many (letter <|> digit <|> symbol)
044                let atom = first:rest
045                return $ case atom of
046                           "#t" -> Bool True
047                           "#f" -> Bool False
048                           otherwise -> Atom atom
049
050 parseNumber :: Parser LispVal
051 parseNumber = liftM (Number . read) $ many1 digit
052
053 parseExpr :: Parser LispVal
054 parseExpr = parseAtom
055            <|> parseString
056            <|> parseNumber
057            <|> parseQuoted
058            <|> do char '('
059                   x <- (try parseList) <|> parseDottedList
060                   char ')'
061                   return x
062
063 parseList :: Parser LispVal
064 parseList = liftM List $ sepBy parseExpr spaces
065
066 parseDottedList :: Parser LispVal
067 parseDottedList = do
068   head <- endBy parseExpr spaces
069   tail <- char '.' >> spaces >> parseExpr
070   return $ DottedList head tail
071
072 parseQuoted :: Parser LispVal
073 parseQuoted = do
074   char '\''
075   x <- parseExpr
076   return $ List [Atom "quote", x]
077
078 eval :: Env -> LispVal -> IOThrowsError LispVal
079 eval env val@(String _) = return val
080 eval env val@(Number _) = return val
081 eval env val@(Bool _) = return val
082 eval env (Atom id) = getVar env id
083 eval env (List [Atom "quote", val]) = return val
084 eval env (List [Atom "if", pred, conseq, alt]) =
085     do result <- eval env pred
086        case result of
087          Bool False -> eval env alt
088          otherwise -> eval env conseq
089 eval env (List [Atom "set!", Atom var, form]) =
090     eval env form >>= setVar env var
091 eval env (List [Atom "load", String filename]) =
092     load filename >>= liftM last . mapM (eval env)
093 eval env (List [Atom "define", Atom var, form]) =
094     eval env form >>= defineVar env var
095 eval env (List (Atom "define" : List (Atom var : params) : body)) =
096     makeNormalFunc env params body >>= defineVar env var
097 eval env (List (Atom "define" : DottedList (Atom var : params) varargs : body)) =
098     makeVarargs varargs env params body >>= defineVar env var
099 eval env (List (Atom "lambda" : List params : body)) =
100     makeNormalFunc env params body
101 eval env (List (Atom "lambda" : DottedList params varargs : body)) =
102     makeVarargs varargs env [] body
103 eval env (List (function : args)) = do
104   func <- eval env function
105   argVals <- mapM (eval env) args
106   apply func argVals
107 eval env badForm = throwError $ BadSpecialForm "Unrecongnized special form" badForm
108
109 car :: [LispVal] -> ThrowsError LispVal
110 car [List (x : xs)] = return x
111 car [DottedList (x : xs) _] = return x
112 car [badArg] = throwError $ TypeMismatch "pair" badArg
113 car badArgList = throwError $ NumArgs 1 badArgList
114
115 cdr :: [LispVal] -> ThrowsError LispVal
116 cdr [List (x : xs)] = return $ List xs
117 cdr [DottedList [xs] x] = return x
118 cdr [DottedList (_ : xs) x] = return $ DottedList xs x
119 cdr [badArg] = throwError $ TypeMismatch "pair" badArg
120 cdr badArgList = throwError $ NumArgs 1 badArgList
121
122
123 cons :: [LispVal] -> ThrowsError LispVal
124 cons [x1, List []] = return $ List [x1]
125 cons [x, List xs] = return $ List $ [x] ++ xs
126 cons [x, DottedList xs xlast] = return $ DottedList ([x] ++ xs) xlast
127 cons [x1, x2] = return $ DottedList [x1] x2
128 cons badArgList = throwError $ NumArgs 2 badArgList
129
130 eqv :: [LispVal] -> ThrowsError LispVal
131 eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2
132 eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2
133 eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2
134 eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2
135 eqv [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) && (and $ map eqvPair $ zip arg1 arg2)
136                                  where eqvPair (x1, x2) = case eqv [x1, x2] of
137                                                             Left err -> False
138                                                             Right (Bool val) -> val
139 eqv [_, _] = return $ Bool False
140 eqv badArgList = throwError $ NumArgs 2 badArgList
141
142 data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)
143
144 unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
145 unpackEquals arg1 arg2 (AnyUnpacker unpacker) = do unpacked1 <- unpacker arg1
146                                                    unpacked2 <- unpacker arg2
147                                                    return $ unpacked1 == unpacked2
148                                                 `catchError` (const $ return False)
149
150 equal :: [LispVal] -> ThrowsError LispVal
151 equal [arg1, arg2] = do
152   primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)
153                      [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
154   eqvEquals <- eqv [arg1, arg2]
155   return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)
156 equal badArgList = throwError $ NumArgs 2 badArgList
157
158 apply :: LispVal -> [LispVal] -> IOThrowsError LispVal
159 apply (PrimitiveFunc func) args = liftThrows $ func args
160 apply (Func params varargs body closure) args =
161     if num params /= num args && varargs == Nothing
162        then throwError $ NumArgs (num params) args
163        else (liftIO $ bindVars closure $ zip params args) >>= bindVarArgs varargs >>= evalBody
164     where remainingArgs = drop (length params) args
165           num = toInteger . length
166           evalBody env = liftM last $ mapM (eval env) body
167           bindVarArgs arg env = case arg of
168                                   Just argName -> liftIO $ bindVars env [(argName, List $ remainingArgs)]
169                                   Nothing -> return env
170 apply (IOFunc func) args = func args
171
172 applyProc :: [LispVal] -> IOThrowsError LispVal
173 applyProc [func, List args] = apply func args
174 applyProc (func : args) = apply func args
175
176 makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
177 makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
178
179 closePort :: [LispVal] -> IOThrowsError LispVal
180 closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)
181 closePort _ = return $ Bool False
182
183 readProc :: [LispVal] -> IOThrowsError LispVal
184 readProc [] = readProc [Port stdin]
185 readProc [Port port] = (liftIO $ hGetLine stdin) >>= liftThrows . readExpr
186
187 writeProc :: [LispVal] -> IOThrowsError LispVal
188 writeProc [obj] = writeProc [obj, Port stdout]
189 writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return $ Bool True)
190
191 readContents :: [LispVal] -> IOThrowsError LispVal
192 readContents [String filename] = liftM String $ liftIO $ readFile filename
193
194 load :: String -> IOThrowsError [LispVal]
195 load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList
196
197 readAll :: [LispVal] -> IOThrowsError LispVal
198 readAll [String filename] = liftM List $ load filename
199
200 primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
201 primitives = [("+", numericBinop (+)),
202               ("-", numericBinop (-)),
203               ("*", numericBinop (*)),
204               ("/", numericBinop (div)),
205               ("mod", numericBinop mod),
206               ("quotient", numericBinop quot),
207               ("remainder", numericBinop rem),
208               ("=", numBoolBinop (==)),
209               ("<", numBoolBinop (<)),
210               (">", numBoolBinop (>)),
211               ("/=", numBoolBinop (/=)),
212               (">=", numBoolBinop (>=)),
213               ("<=", numBoolBinop (<=)),
214               ("&&", boolBoolBinop (&&)),
215               ("||", boolBoolBinop (||)),
216               ("string=?", strBoolBinop (==)),
217               ("string<?", strBoolBinop (<)),
218               ("string>?", strBoolBinop (>)),
219               ("string<=?", strBoolBinop (<=)),
220               ("string>=?", strBoolBinop (>=)),
221               ("car", car),
222               ("cdr", cdr),
223               ("cons", cons),
224               ("eq?", eqv),
225               ("eqv?", eqv),
226               ("equal?", equal)]
227
228 ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]
229 ioPrimitives = [("apply", applyProc),
230                 ("open-input-file", makePort ReadMode),
231                 ("open-output-file", makePort WriteMode),
232                 ("close-input-port", closePort),
233                 ("close-output-port", closePort),
234                 ("read", readProc),
235                 ("write", writeProc),
236                 ("read-contents", readContents),
237                 ("read-all", readAll)]
238
239 primitiveBindings :: IO Env
240 primitiveBindings = nullEnv >>= (flip bindVars $ map (makeFunc IOFunc) ioPrimitives
241                     ++ map (makeFunc PrimitiveFunc) primitives)
242                     where makeFunc constructor (var, func) = (var, constructor func)
243
244 numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
245 numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
246 numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op
247
248 boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
249 boolBinop unpacker op args = if length args /= 2
250                              then throwError $ NumArgs 2 args
251                              else do left <- unpacker $ args !! 0
252                                      right <- unpacker $ args !! 1
253                                      return $ Bool $ left `op` right
254
255 numBoolBinop = boolBinop unpackNum
256 strBoolBinop = boolBinop unpackStr
257 boolBoolBinop = boolBinop unpackBool
258
259 unpackNum :: LispVal -> ThrowsError Integer
260 unpackNum (Number n) = return n
261 unpackNum (String n) = let parsed = reads n in
262                        if null parsed
263                           then throwError $ TypeMismatch "number" $ String n
264                           else return $ fst $ parsed !! 0
265 unpackNum (List [n]) = unpackNum n
266 unpackNum notNum = throwError $ TypeMismatch "number" notNum
267
268 unpackStr :: LispVal -> ThrowsError String
269 unpackStr (String s) = return s
270 unpackStr (Number s) = return $ show s
271 unpackStr (Bool s) = return $ show s
272 unpackStr notString = throwError $ TypeMismatch "string" notString
273
274 unpackBool :: LispVal -> ThrowsError Bool
275 unpackBool (Bool b) = return b
276 unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
277
278 readOrThrow :: Parser a -> String -> ThrowsError a
279 readOrThrow parser input = case parse parser "lisp" input of
280                              Left err -> throwError $ Parser err
281                              Right val -> return val
282
283 readExpr :: String -> ThrowsError LispVal
284 readExpr = readOrThrow parseExpr
285 readExprList = readOrThrow (endBy parseExpr spaces)
286
287 showVal :: LispVal -> String
288 showVal (String contents) = "\"" ++ contents ++ "\""
289 showVal (Atom name) = name
290 showVal (Number contents) = show contents
291 showVal (Bool True) = "#t"
292 showVal (Bool False) = "#f"
293 showVal (List contents) = "(" ++ unwordsList contents ++ ")"
294 showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
295 showVal (PrimitiveFunc _) = "<primitive>"
296 showVal (Func {params = args, vararg = varargs, body = body, closure = env}) =
297     "(lambda (" ++ unwords (map show args) ++
298                 (case varargs of
299                    Nothing -> ""
300                    Just arg -> " . " ++ arg) ++ ") ...)"
301 showVal (Port _) = "<IO port>"
302 showVal (IOFunc _) = "<IO primitive>"
303
304 showError :: LispError -> String
305 showError (UnboundVar message varname) = message ++ ": " ++ varname
306 showError (BadSpecialForm message form) = message ++ ": " ++ show form
307 showError (NotFunction message func) = message ++ ": " ++ show func
308 showError (NumArgs expected found) = "Expected " ++ show expected
309                                      ++ " args; found values " ++ unwordsList found
310 showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected ++ ", found " ++ show found
311 showError (Parser parseErr) = "Parse error at " ++ show parseErr
312
313 instance Show LispError where show = showError
314
315 instance Error LispError where
316     noMsg = Default "An error has occurred"
317     strMsg = Default
318
319 type ThrowsError = Either LispError
320
321 trapError action = catchError action (return . show)
322
323 extractValue :: ThrowsError a -> a
324 extractValue (Right val) = val
325
326 unwordsList :: [LispVal] -> String
327 unwordsList = unwords . map showVal
328
329 instance Show LispVal where show = showVal
330
331 type Env = IORef [(String, IORef LispVal)]
332
333 nullEnv :: IO Env
334 nullEnv = newIORef []
335
336 type IOThrowsError = ErrorT LispError IO
337 liftThrows :: ThrowsError a -> IOThrowsError a
338 liftThrows (Left err) = throwError err
339 liftThrows (Right val) = return val
340
341 runIOThrows :: IOThrowsError String -> IO String
342 runIOThrows action = runErrorT (trapError action) >>= return . extractValue
343
344 isBound :: Env -> String -> IO Bool
345 isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var
346
347 getVar :: Env -> String -> IOThrowsError LispVal
348 getVar envRef var = do env <- liftIO $ readIORef envRef
349                        maybe (throwError $ UnboundVar "Getting an unbound variable" var)
350                              (liftIO . readIORef)
351                              (lookup var env)
352
353 setVar :: Env -> String -> LispVal -> IOThrowsError LispVal
354 setVar envRef var value = do env <- liftIO $ readIORef envRef
355                              maybe (throwError $ UnboundVar "Setting an unbound variable" var)
356                                    (liftIO . (flip writeIORef value))
357                                    (lookup var env)
358                              return value
359
360 defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal
361 defineVar envRef var value = do
362   alreadyDefined <- liftIO $ isBound envRef var
363   if alreadyDefined
364      then setVar envRef var value >> return value
365      else liftIO $ do
366        valueRef <- newIORef value
367        env <- readIORef envRef
368        writeIORef envRef ((var, valueRef) : env)
369        return value
370
371 makeFunc varargs env params body = return $ Func (map showVal params) varargs body env
372
373 makeNormalFunc = makeFunc Nothing
374
375 makeVarargs = makeFunc . Just . showVal
376
377 bindVars :: Env -> [(String, LispVal)] -> IO Env
378 bindVars envRef bindings = readIORef envRef >>= extendEnv bindings >>= newIORef
379                            where extendEnv bindings env = liftM (++ env) (mapM addBinding bindings)
380                                  addBinding (var, value) = do ref <- newIORef value
381                                                               return (var, ref)
382
383 flushStr :: String -> IO()
384 flushStr str = putStr str >> hFlush stdout
385
386 readPrompt :: String -> IO String
387 readPrompt prompt = flushStr prompt >> getLine
388
389 evalString :: Env -> String -> IO String
390 evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= eval env
391
392 evalAndPrint :: Env -> String -> IO ()
393 evalAndPrint env expr = evalString env expr >>= putStrLn
394
395
396
397 until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m ()
398 until_ pred prompt action = do
399   result <- prompt
400   if pred result
401      then return ()
402      else action result >> until_ pred prompt action
403
404 runOne :: [String] -> IO ()
405 runOne args = do
406   env <- primitiveBindings >>= flip bindVars [("args", List $ map String $ drop 1 args)]
407   (runIOThrows $ liftM show $ eval env (List [Atom "load", String (args !! 0)]))
408               >>= hPutStrLn stderr
409
410 runRepl :: IO ()
411 runRepl = primitiveBindings >>= until_ (== "quit") (readPrompt "Lisp>>> ") . evalAndPrint
412
413 main :: IO()
414 main = do args <- getArgs
415           if null args then runRepl else runOne $ args