REPL and some minor changes

Author: charrsky

app/Main.hs

@@ -1,14 +1,41 @@
 module Main where
 
+import Definitions
 import Evaluation
 import Parsing
 import Text.ParserCombinators.Parsec hiding (spaces)
 import System.Environment
 import Control.Monad
+import System.IO
 
 
+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 "Lisp>>> ") evalAndPrint
+
 main :: IO ()
 main = do
      args <- getArgs
-     evaled <- return $ liftM show $ readExpr (args !! 0) >>= eval
-     putStrLn $ extractValue $ trapError evaled
+     case length args of
+       0 -> runRepl
+       1 -> evalAndPrint $ args !! 0
+       _ -> putStrLn "Program takes only 0 or 1 argument"

my-scheme.cabal

@@ -25,11 +25,10 @@ source-repository head
 
 library
   exposed-modules:
-      Evaluation Parsing
-  other-modules:
-      Definitions
       Evaluation
       Parsing
+      Definitions
+  other-modules:
       Paths_my_scheme
   hs-source-dirs:
       src

package.yaml

@@ -27,9 +27,12 @@ dependencies:
 
 library:
   source-dirs: src
-  exposed-modules: Evaluation
-                   Parsing
-  default-extensions: ExistentialQuantification
+  exposed-modules:
+  - Evaluation
+  - Parsing
+  - Definitions
+  default-extensions:
+  - ExistentialQuantification
 
 executables:
   my-scheme-exe:

src/Definitions.hs

@@ -63,16 +63,3 @@ trapError action = catchError action (return . show)
 
 extractValue :: ThrowsError a -> a
 extractValue (Right val) = val
-
-checkType :: LispVal -> String
-checkType (Atom _) = "Atom"
-checkType (List _) = "List"
-checkType (DottedList _ _) = "DottedList"
-checkType (Number _) = "Number"
-checkType (Bool _) = "Bool"
-checkType (Char _) = "Char"
-checkType (Float _) = "Float"
-checkType (Ratio _) = "Ratio"
-checkType (Complex _) = "Complex"
-checkType (Vector _) = "Vector"
-checkType _ = "List"

src/Evaluation.hs

@@ -14,7 +14,7 @@ eval (List [Atom "if", pred, conseq, alt]) =
      case result of
        Bool False -> eval alt
        Bool True -> eval conseq
-       _ -> throwError $ TypeMismatch "Bool" $ checkType pred
+       _ -> throwError $ TypeMismatch "Bool" pred
 eval (List (Atom func : args)) = mapM eval args >>= apply func
 eval form@(List (Atom "cond" : clauses)) =
   if null clauses
@@ -34,7 +34,7 @@ eval form@(List (Atom "case" : key : clauses)) =
     List ((List datums) : exprs) -> do
       result <- eval key
       equality <- mapM (\x -> eqv [result, x]) datums
-      if Boolean True `elem` equality
+      if Bool True `elem` equality
         then mapM eval exprs >>= return . last
         else eval $ List (Atom "case" : key : tail clauses)
     _ -> throwError $ BadSpecialForm "ill-formed case expression: " form
@@ -100,10 +100,10 @@ unpackNum :: LispVal -> ThrowsError Integer
 unpackNum (Number n) = return n
 unpackNum (String n) = let parsed = reads n :: [(Integer, String)] in
                          if null parsed
-                            then throwError $ TypeMismatch "number" $ String n
+                            then throwError $ TypeMismatch "Number" $ String n
                             else return $ fst $ parsed !! 0
 unpackNum (List [n]) = unpackNum n
-unpackNum notNum = throwError $ TypeMismatch "number" notNum
+unpackNum notNum = throwError $ TypeMismatch "Number" notNum
 
 symbolp, integerp, floatp, ratiop, complexp, stringp, boolp, listp, vectorp
   :: LispVal -> LispVal
@@ -143,11 +143,11 @@ 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" $ checkType notString
+unpackStr notString = throwError $ TypeMismatch "String" notString
 
 unpackBool :: LispVal -> ThrowsError Bool
 unpackBool (Bool b) = return b
-unpackBool notBool = throwError $ TypeMismatch "Bool" $ checkType notBool
+unpackBool notBool = throwError $ TypeMismatch "Bool" notBool
 
 symbol2string, string2symbol :: LispVal -> LispVal
 symbol2string (Atom s) = String s
@@ -158,14 +158,14 @@ string2symbol _ = Atom ""
 car :: [LispVal] -> ThrowsError LispVal
 car [List (x : _)]         = return x
 car [DottedList (x : _) _] = return x
-car [badArg]                = throwError $ TypeMismatch "Pair" $ checkType badArg
+car [badArg]                = throwError $ TypeMismatch "Pair" badArg
 car badArgList              = throwError $ NumArgs 1 badArgList
 
 cdr :: [LispVal] -> ThrowsError LispVal
 cdr [List (_ : xs)]         = return $ List xs
 cdr [DottedList [_] x]      = return x
 cdr [DottedList (_ : xs) x] = return $ DottedList xs x
-cdr [badArg]                = throwError $ TypeMismatch "Pair" $ checkType badArg
+cdr [badArg]                = throwError $ TypeMismatch "Pair" badArg
 cdr badArgList              = throwError $ NumArgs 1 badArgList
 
 cons :: [LispVal] -> ThrowsError LispVal
@@ -216,14 +216,14 @@ equal badArgList = throwError $ NumArgs 2 badArgList
 
 stringLen :: [LispVal] -> ThrowsError LispVal
 stringLen [(String s)] = Right $ Number $ fromIntegral $ length s
-stringLen [notString] = throwError $ TypeMismatch "String" $ checkType notString
+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" $ checkType notNum
-stringRef [notString, _] = throwError $ TypeMismatch "String" $ checkType notString
+stringRef [(String s), notNum] = throwError $ TypeMismatch "Number" notNum
+stringRef [notString, _] = throwError $ TypeMismatch "String" notString
 stringRef badArgList = throwError $ NumArgs 2 badArgList