hazel
/
very-nice
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
Browse Source

VARIABLES WORK HAHA YES asdjf

canon
abraham levine 5 years ago
parent
dda7abe9a6
commit
b95b5b4f94
4 changed files with 172 additions and 66 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 136
      TAGS
  2. 4
      app/Main.hs
  3. 84
      src/Scheme/Eval.hs
  4. 14
      src/Scheme/REPL.hs

136
TAGS
Unescape View File

@ -72,6 +72,23 @@ parseExpr parseExpr183,184
unwordsList unwordsList197,198
unwordsList unwordsList198,199
./src/Scheme/REPL.hs,397
module Scheme.REPLScheme.REPL2,3
flushStr flushStr18,19
flushStr flushStr19,20
readPrompt readPrompt21,22
readPrompt readPrompt22,23
evalString evalString24,25
evalString evalString25,26
evalAndPrint evalAndPrint27,28
evalAndPrint evalAndPrint28,29
until_ until_30,31
until_ until_31,32
runOne runOne37,38
runOne runOne38,39
runRepl runRepl40,41
runRepl runRepl41,42
./src/Scheme/LispVal.hs,477
module Scheme.LispValScheme.LispVal5,6
data LispVal LispVal16,17
@ -112,48 +129,85 @@ extractValue extractValue45,46
unwordsList unwordsList49,50
unwordsList unwordsList50,51
./src/Scheme/Eval.hs,941
module Scheme.EvalScheme.Eval6,7
unwordsList unwordsList20,21
unwordsList unwordsList21,22
eval eval23,24
eval eval25,26
apply apply32,33
apply apply33,34
primitives primitives37,38
primitives primitives38,39
numericBinop numericBinop60,61
numericBinop numericBinop61,62
unpackNum unpackNum66,67
unpackNum unpackNum67,68
unaryOp unaryOp71,72
unaryOp unaryOp72,73
symbolp symbolp75,76
pairp pairp76,77
listp listp77,78
boolp boolp78,79
charp charp79,80
stringp stringp80,81
vectorp vectorp81,82
symbolp symbolp83,84
pairp pairp85,86
listp listp88,89
boolp boolp90,91
charp charp92,93
stringp stringp94,95
vectorp vectorp96,97
numberp numberp100,101
complexp complexp101,102
realp realp102,103
rationalp rationalp103,104
integerp integerp104,105
numberp numberp106,107
complexp complexp107,108
realp realp109,110
rationalp rationalp111,112
integerp integerp113,114
./src/Scheme/Eval.hs,1933
module Scheme.EvalScheme.Eval5,6
data Unpacker Unpacker25,26
data Unpacker = forall forall25,26
type Env Env26,27
type IOThrowsError IOThrowsError27,28
eval eval30,31
eval eval31,32
apply apply49,50
apply apply50,51
nullEnv nullEnv55,56
nullEnv nullEnv56,57
liftThrows liftThrows58,59
liftThrows liftThrows59,60
runIOThrows runIOThrows62,63
runIOThrows runIOThrows63,64
isBound isBound65,66
isBound isBound66,67
getVar getVar68,69
getVar getVar69,70
setVar setVar74,75
setVar setVar75,76
defineVar defineVar81,82
defineVar defineVar82,83
primitives primitives92,93
primitives primitives93,94
numericBinop numericBinop137,138
numericBinop numericBinop138,139
boolBinop boolBinop142,143
boolBinop boolBinop143,144
numBoolBinop numBoolBinop148,149
strBoolBinop strBoolBinop149,150
boolBoolBinop boolBoolBinop150,151
unaryOp unaryOp152,153
unaryOp unaryOp153,154
unpackNum unpackNum156,157
unpackNum unpackNum157,158
unpackStr unpackStr161,162
unpackStr unpackStr162,163
unpackBool unpackBool167,168
unpackBool unpackBool168,169
unpackEquals unpackEquals171,172
unpackEquals unpackEquals172,173
symbolp symbolp179,180
pairp pairp180,181
listp listp181,182
boolp boolp182,183
charp charp183,184
stringp stringp184,185
vectorp vectorp185,186
symbolp symbolp187,188
pairp pairp189,190
listp listp192,193
boolp boolp194,195
charp charp196,197
stringp stringp198,199
vectorp vectorp200,201
numberp numberp204,205
complexp complexp205,206
realp realp206,207
rationalp rationalp207,208
integerp integerp208,209
numberp numberp210,211
complexp complexp211,212
realp realp213,214
rationalp rationalp215,216
integerp integerp217,218
car car221,222
car car222,223
cdr cdr227,228
cdr cdr228,229
cons cons234,235
cons cons235,236
eqv eqv242,243
eqv eqv243,244
equal equal256,257
equal equal257,258
./app/Main.hs,56
module Main Main0,1
main main11,12
main main12,13
main main13,14

4
app/Main.hs
Unescape View File

@ -15,5 +15,5 @@ main = do
args <- getArgs
case length args of
0 -> runRepl
1 -> evalAndPrint $ args !! 0
otherwise -> putStrLn "very-nice: only takes 1 argument"
1 -> runOne $ args !! 0
_ -> putStrLn "very-nice: only takes 1 argument"

84
src/Scheme/Eval.hs
Unescape View File

@ -5,7 +5,11 @@
module Scheme.Eval
( showVal
, eval )
, eval
, Env
, nullEnv
, liftThrows
, runIOThrows )
where
import Data.Text (Text)
@ -13,35 +17,79 @@ import qualified Data.Text as T
import Data.Complex
import Data.Ratio
import Control.Monad.Except
import Data.IORef
import Control.Applicative
import Scheme.LispVal
import Scheme.Error
data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)
type Env = IORef [(String, IORef LispVal)]
type IOThrowsError = ExceptT LispError IO
unwordsList :: [LispVal] -> Text
unwordsList = T.unwords . map showVal
eval :: LispVal -> ThrowsError LispVal
-- self-evaluating
eval val@(String _) = return val
eval val@(Number _) = return val
eval val@(Bool _) = return val
eval (List [Atom "quote", val]) = return val
eval (List [Atom "if", pred1, conseq, alt]) =
do result <- eval pred1
-- THE. EVALUATOR.
eval :: Env -> LispVal -> IOThrowsError LispVal
eval env val@(String _) = return val
eval env val@(Number _) = return val
eval env val@(Bool _) = return val
eval env (Atom id) = getVar env $ T.unpack id
eval env (List [Atom "quote", val]) = return val
eval env (List [Atom "if", pred1, conseq, alt]) =
do result <- eval env pred1
case result of
Bool False -> eval alt
Bool True -> eval conseq
Bool False -> eval env alt
Bool True -> eval env 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
eval env (List [Atom "set!", Atom var, form]) =
eval env form >>= setVar env (T.unpack var)
eval env (List [Atom "define", Atom var, form]) =
eval env form >>= defineVar env (T.unpack var)
eval env (List (Atom func : args)) = mapM (eval env) args >>= liftThrows . apply (T.unpack func)
eval env badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm
apply :: String -> [LispVal] -> ThrowsError LispVal
apply func args = maybe (throwError $ NotFunction "Unrecognized primitive function args" func)
($ args)
(lookup func primitives)
-- mutability
nullEnv :: IO Env
nullEnv = newIORef []
liftThrows :: ThrowsError a -> IOThrowsError a
liftThrows (Left err) = throwError err
liftThrows (Right val) = return val
runIOThrows :: IOThrowsError String -> IO String
runIOThrows act = runExceptT (trapError act) >>= return . extractValue
isBound :: Env -> String -> IO Bool
isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var
getVar :: Env -> String -> IOThrowsError LispVal
getVar envRef var = do env <- liftIO $ readIORef envRef
maybe (throwError $ UnboundVar "Attempting to get unbound variable" var)
(liftIO . readIORef)
(lookup var env)
setVar :: Env -> String -> LispVal -> IOThrowsError LispVal
setVar envRef var value = do env <- liftIO $ readIORef envRef
maybe (throwError $ UnboundVar "Attempting to get unbound variable" var)
(liftIO . (flip writeIORef value))
(lookup var env)
return value
defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal
defineVar envRef var value = do
alreadyDefined <- liftIO $ isBound envRef var
if alreadyDefined
then setVar envRef var value >> return value
else liftIO $ do valueRef <- newIORef value
env <- readIORef envRef
_ <- writeIORef envRef ((var, valueRef):env)
return value
-- list of primitives implemented
primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives = [ ("car", car)
, ("cdr", cdr)
@ -208,8 +256,8 @@ eqv badArgList = throwError $ NumArgs 2 badArgList
equal :: [LispVal] -> ThrowsError LispVal
equal [uno, dos] = do
primEq <- liftM or $ mapM (unpackEquals uno dos)
primEq <- or <$> mapM (unpackEquals uno dos)
[AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
eqvEq <- eqv [uno, dos]
return $ Bool $ (primEq || let (Bool x) = eqvEq in x)
return $ Bool (primEq || let (Bool x) = eqvEq in x)
equal badArgList = throwError $ NumArgs 2 badArgList

14
src/Scheme/REPL.hs
Unescape View File

@ -2,6 +2,7 @@
module Scheme.REPL
( runRepl
, runOne
, evalAndPrint )
where
@ -21,11 +22,11 @@ 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)
evalString :: Env -> String -> IO String
evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= eval env
evalAndPrint :: String -> IO ()
evalAndPrint expr = evalString expr >>= putStrLn
evalAndPrint :: Env -> String -> IO ()
evalAndPrint env expr = evalString env expr >>= putStrLn
until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m ()
until_ pred' prompt action = do
@ -34,5 +35,8 @@ until_ pred' prompt action = do
then return ()
else action result >> until_ pred' prompt action
runOne :: String -> IO ()
runOne expr = nullEnv >>= flip evalAndPrint expr
runRepl :: IO ()
runRepl = until_ (== "quit") (readPrompt "verynice>>> ") evalAndPrint
runRepl = nullEnv >>= until_ (== "quit") (readPrompt "verynice>>> ") . evalAndPrint

Write Preview
Loading…
Cancel
Save