Browse Source

add weak typechecking and primitive REPL

canon
abraham levine 3 years ago
parent
commit
dda7abe9a6
4 changed files with 70 additions and 6 deletions
  1. +5
    -2
      app/Main.hs
  2. +26
    -4
      src/Scheme/Eval.hs
  3. +38
    -0
      src/Scheme/REPL.hs
  4. +1
    -0
      very-nice2.cabal

+ 5
- 2
app/Main.hs View File

@ -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"

+ 26
- 4
src/Scheme/Eval.hs View File

@ -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

+ 38
- 0
src/Scheme/REPL.hs View File

@ -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

+ 1
- 0
very-nice2.cabal View File

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


Loading…
Cancel
Save