add weak typechecking and primitive REPL

app/Main.hs

@@ -8,9 +8,12 @@ import Control.Monad
 import Scheme.Parse
 import Scheme.Eval
 import Scheme.Error
+import Scheme.REPL
 
 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
+    otherwise -> putStrLn "very-nice: only takes 1 argument"

src/Scheme/Eval.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, ExistentialQuantification #-}
 
 -- TODO:
 -- - refactor numericBinop to support non-Integer types
@@ -17,6 +17,8 @@ import Control.Monad.Except
 import Scheme.LispVal
 import Scheme.Error
 
+data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)
+
 unwordsList :: [LispVal] -> Text
 unwordsList = T.unwords . map showVal
 
@@ -30,7 +32,8 @@ eval (List [Atom "if", pred1, conseq, alt]) =
   do result <- eval pred1
      case result of
        Bool False -> eval alt
-       _ -> eval conseq
+       Bool True  -> eval conseq
+       notBool    -> throwError $ TypeMismatch "boolean" notBool
 eval (List (Atom func : args)) = mapM eval args >>= apply (T.unpack func)
 eval badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm
 
@@ -42,6 +45,10 @@ apply func args = maybe (throwError $ NotFunction "Unrecognized primitive functi
 primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
 primitives = [ ("car", car)
              , ("cdr", cdr)
+             , ("cons", cons)
+             , ("eq?", eqv)
+             , ("eqv?", eqv)
+             , ("equal?", equal)
 
              , ("+", numericBinop (+))
              , ("-", numericBinop (-))
@@ -114,6 +121,13 @@ unpackBool :: LispVal -> ThrowsError Bool
 unpackBool (Bool b) = return b
 unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
 
+unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
+unpackEquals uno dos (AnyUnpacker unpacker) =
+  do unpackuno <- unpacker uno
+     unpackdos <- unpacker dos
+     return $ unpackuno == unpackdos
+  `catchError` (const $ return False)
+
 -- type testing
 symbolp :: LispVal -> LispVal
 pairp   :: LispVal -> LispVal
@@ -185,9 +199,17 @@ eqv [(String uno), (String dos)] = return $ Bool $ uno == dos
 eqv [(Atom uno), (Atom dos)] = return $ Bool $ uno == dos
 eqv [(DottedList xs x), (DottedList ys y)] = eqv $ [List $ xs ++ [x], List $ ys ++ [y]]
 eqv [(List uno), (List dos)] = return $ Bool $ (length uno == length dos) &&
-                                               (all eqvPair $ zip arg1 arg2)
+                                               (all eqvPair $ zip uno dos) 
   where eqvPair (x1, x2) = case eqv [x1, x2] of
           Left err -> False
-          Right (Bool val) -> val = return $ Bool False
+          Right (Bool val) -> val
 eqv [_, _] = return $ Bool False
 eqv badArgList = throwError $ NumArgs 2 badArgList
+
+equal :: [LispVal] -> ThrowsError LispVal
+equal [uno, dos] = do
+  primEq <- liftM or $ mapM (unpackEquals uno dos)
+                       [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
+  eqvEq  <- eqv [uno, dos]
+  return $ Bool $ (primEq || let (Bool x) = eqvEq in x)
+equal badArgList = throwError $ NumArgs 2 badArgList

src/Scheme/REPL.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Scheme.REPL
+  ( runRepl
+  , evalAndPrint )
+  where
+
+-- TODO: readline/bksp w/out rlwrap
+--       overall this is really simplistic and needs work bad
+
+import System.IO
+import Control.Monad.Except
+
+import Scheme.Error
+import Scheme.Eval
+import Scheme.Parse
+
+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 "verynice>>> ") evalAndPrint

very-nice2.cabal

@@ -17,6 +17,7 @@ library
                      , Scheme.LispVal
                      , Scheme.Eval
                      , Scheme.Error
+                     , Scheme.REPL
   build-depends:       base >= 4.7 && < 5
                      , parsec
                      , text