Browse Source

IO added

master
parent
commit
714e171a1b
  1. 76
      scheme.hs

76
scheme.hs

@ -23,6 +23,8 @@ data LispVal = Atom String
| PrimitiveFunc ([LispVal] -> ThrowsError LispVal)
| Func {params :: [String], vararg :: (Maybe String),
body :: [LispVal], closure :: Env}
| IOFunc ([LispVal] -> IOThrowsError LispVal)
| Port Handle
parseString :: Parser LispVal
parseString = do
@ -127,6 +129,8 @@ showVal (Func {params = args, vararg = varargs, body = body, closure = env}) =
(case varargs of
Nothing -> ""
Just arg -> " . " ++ arg) ++ ") ...)"
showVal (Port _) = "<IO port>"
showVal (IOFunc _) = "<IO primitive>"
unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal
@ -161,6 +165,8 @@ 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
eval env (List [Atom "load", String filename])=
load filename >>= liftM last . mapM (eval env)
eval env (List (function : args)) = do
func <- eval env function
argVals <- mapM (eval env) args
@ -180,10 +186,11 @@ apply (Func params varargs body closure) args =
bindVarArgs arg env = case arg of
Just argName -> liftIO $ bindVars env [(argName, List $ remainingArgs)]
Nothing -> return env
apply (IOFunc func) args = func args
primitiveBindings :: IO Env
primitiveBindings = nullEnv >>= (flip bindVars $ map makePrimitiveFunc primitives)
where makePrimitiveFunc (var, func) = (var, PrimitiveFunc func)
primitiveBindings = nullEnv >>= (flip bindVars $ map (makeFunc IOFunc) ioPrimitives ++ map (makeFunc PrimitiveFunc) primitives)
where makeFunc constructor (var, func) = (var, constructor func)
primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives = [("+", numericBinop (+)),
@ -366,8 +373,11 @@ until_ pred prompt action = do
then return()
else action result >> until_ pred prompt action
runOne :: String -> IO ()
runOne expr = primitiveBindings >>= flip evalAndPrint expr
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
runRepl :: IO ()
runRepl = primitiveBindings >>= until_ (== "quit") (readPrompt "Lisp>>> ") . evalAndPrint
@ -429,16 +439,58 @@ makeFunc varargs env params body = return $ Func (map showVal params) varargs bo
makeNormalFunc = makeFunc Nothing
makeVarargs = makeFunc . Just . showVal
-- IO
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)]
applyProc :: [LispVal] -> IOThrowsError LispVal
applyProc [func, List args] = apply func args
applyProc (func : args) = apply func args
makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
closePort :: [LispVal] -> IOThrowsError LispVal
closePort [Port port] = liftIO $ hClose port >> (return $ Bool True)
closePort _ = return $ Bool False
readProc :: [LispVal] -> IOThrowsError LispVal
readProc [] = readProc [Port stdin]
readProc [Port port] = (liftIO $ hGetLine port) >>= liftThrows . readExpr
writeProc :: [LispVal] -> IOThrowsError LispVal
writeProc [obj] = writeProc [obj, Port stdout]
writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return $ Bool True)
readContents :: [LispVal] -> IOThrowsError LispVal
readContents [String filename] = liftM String $ liftIO $ readFile filename
load :: String -> IOThrowsError [LispVal]
load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList
readAll :: [LispVal] -> IOThrowsError LispVal
readAll [String filename] = liftM List $ load filename
-- Main
readExpr :: String -> ThrowsError LispVal
readExpr input = case parse parseExpr "lisp" input of
Left err -> throwError $ Parser err
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 :: String -> ThrowsError LispVal
readExpr = readOrThrow parseExpr
readExprList = readOrThrow (endBy parseExpr spaces)
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"
args <- getArgs
if null args then runRepl else runOne $ args

Loading…
Cancel
Save