Permalink
Browse files

Working REPL

  • Loading branch information...
1 parent b51a197 commit de74bfe2b7efb5defdad516ee29583657222c11e @abedra committed Apr 7, 2012
Showing with 56 additions and 32 deletions.
  1. +56 −32 valence.hs
View
@@ -2,6 +2,7 @@ module Main where
import System.Environment
import Control.Monad
import Control.Monad.Error
+import IO hiding (try)
import Text.ParserCombinators.Parsec hiding (spaces)
data LispVal = Atom String
@@ -22,34 +23,6 @@ data LispError = NumArgs Integer [LispVal]
symbol :: Parser Char
symbol = oneOf "#!$%&|*+-/:<=>?@^_-"
-primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
-primitives = [("+", operator (+)),
- ("-", operator (-)),
- ("*", operator (*)),
- ("/", operator div),
- ("mod", operator mod),
- ("quotient", operator quot),
- ("remainder", operator rem),
- ("=", numBoolBinop (==)),
- ("<", numBoolBinop (<)),
- (">", numBoolBinop (>)),
- ("/=", numBoolBinop (/=)),
- (">=", numBoolBinop (>=)),
- ("<=", numBoolBinop (<=)),
- ("&&", boolBoolBinop (&&)),
- ("||", boolBoolBinop (||)),
- ("string=?", strBoolBinop (==)),
- ("string<?", strBoolBinop (<)),
- ("string>?", strBoolBinop (>)),
- ("string<=?", strBoolBinop (<=)),
- ("string>=?", strBoolBinop (>=)),
- ("car", car),
- ("cdr", cdr),
- ("cons", cons),
- ("eq?", eqv),
- ("eqv?", eqv),
- ("equal?", equal)]
-
operator :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
operator op singleVal@[_] = throwError $ NumArgs 2 singleVal
operator op params = mapM unpackNum params >>= return . Number . foldl1 op
@@ -179,6 +152,34 @@ equal [arg1, arg2] = do
return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)
equal badArgList = throwError $ NumArgs 2 badArgList
+primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
+primitives = [("+", operator (+)),
+ ("-", operator (-)),
+ ("*", operator (*)),
+ ("/", operator div),
+ ("mod", operator mod),
+ ("quotient", operator quot),
+ ("remainder", operator rem),
+ ("=", numBoolBinop (==)),
+ ("<", numBoolBinop (<)),
+ (">", numBoolBinop (>)),
+ ("/=", numBoolBinop (/=)),
+ (">=", numBoolBinop (>=)),
+ ("<=", numBoolBinop (<=)),
+ ("&&", boolBoolBinop (&&)),
+ ("||", boolBoolBinop (||)),
+ ("string=?", strBoolBinop (==)),
+ ("string<?", strBoolBinop (<)),
+ ("string>?", strBoolBinop (>)),
+ ("string<=?", strBoolBinop (<=)),
+ ("string>=?", strBoolBinop (>=)),
+ ("car", car),
+ ("cdr", cdr),
+ ("cons", cons),
+ ("eq?", eqv),
+ ("eqv?", eqv),
+ ("equal?", equal)]
+
instance Show LispVal where show = showVal
unwordsList :: [LispVal] -> String
unwordsList = unwords . map showVal
@@ -208,6 +209,28 @@ showError (NumArgs expected found) = "Expected " ++ show expected ++ " arguments
showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected ++ ", found " ++ show found
showError (Parser parseErr) = "Parse error at " ++ show parseErr
+flushStr :: String -> IO ()
+flushStr str = putStr str >> hFlush stdout
+
+readPrompt :: String -> IO String
+readPrompt prompt = flushStr prompt >> getLine
+
+evalString :: String -> IO String
+evalString expr = return $ extractValue $ trapError (liftM show $ readExpr expr >>= eval)
+
+evalAndPrint :: String -> IO ()
+evalAndPrint expr = evalString expr >>= putStrLn
+
+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
+
+runRepl :: IO ()
+runRepl = until_ (== "quit") (readPrompt "Valence>> ") evalAndPrint
+
readExpr :: String -> ThrowsError LispVal
readExpr input = case parse parseExpr "lisp" input of
Left err -> throwError $ Parser err
@@ -232,7 +255,8 @@ eval (List (Atom func : args)) = mapM eval args >>= apply func
eval badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm
main :: IO ()
-main = do
- args <- getArgs
- evaled <- return $ liftM show $ readExpr (args !! 0) >>= eval
- putStrLn $ extractValue $ trapError evaled
+main = do args <- getArgs
+ case length args of
+ 0 -> runRepl
+ 1 -> evalAndPrint $ args !! 0
+ otherwise -> putStrLn "Program takes only 0 or 1 arguments"

0 comments on commit de74bfe

Please sign in to comment.