Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: abedra/Valence
base: 61921ff0e1
...
head fork: abedra/Valence
compare: cac917c54d
  • 2 commits
  • 2 files changed
  • 0 commit comments
  • 1 contributor
Showing with 39 additions and 2 deletions.
  1. +3 −0  script/build
  2. +36 −2 valence.hs
View
3  script/build
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+ghc -package parsec -o valence valence.hs
View
38 valence.hs
@@ -29,12 +29,46 @@ primitives = [("+", operator (+)),
("/", operator div),
("mod", operator mod),
("quotient", operator quot),
- ("remainder", operator rem)]
+ ("remainder", operator rem),
+ ("=", numBoolBinop (==)),
+ ("<", numBoolBinop (<)),
+ (">", numBoolBinop (>)),
+ ("/=", numBoolBinop (/=)),
+ (">=", numBoolBinop (>=)),
+ ("<=", numBoolBinop (<=)),
+ ("&&", boolBoolBinop (&&)),
+ ("||", boolBoolBinop (||)),
+ ("string=?", strBoolBinop (==)),
+ ("string<?", strBoolBinop (<)),
+ ("string>?", strBoolBinop (>)),
+ ("string<=?", strBoolBinop (<=)),
+ ("string>=?", strBoolBinop (>=))]
operator :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
operator op singleVal@[_] = throwError $ NumArgs 2 singleVal
operator op params = mapM unpackNum params >>= return . Number . foldl1 op
+boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
+boolBinop unpacker op args = if length args /= 2
+ then throwError $ NumArgs 2 args
+ else do left <- unpacker $ args !! 0
+ right <- unpacker $ args !! 1
+ return $ Bool $ left `op` right
+
+numBoolBinop = boolBinop unpackNum
+strBoolBinop = boolBinop unpackStr
+boolBoolBinop = boolBinop unpackBool
+
+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" notString
+
+unpackBool :: LispVal -> ThrowsError Bool
+unpackBool (Bool b) = return b
+unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
+
unpackNum :: LispVal -> ThrowsError Integer
unpackNum (Number n) = return n
unpackNum (String n) = let parsed = reads n in
@@ -115,7 +149,7 @@ showError :: LispError -> String
showError (UnboundVar message varname) = message ++ ": " ++ varname
showError (BadSpecialForm message form) = message ++ ": " ++ show form
showError (NotFunction message func) = message ++ ": " ++ show func
-showError (NumArgs expected found) = "Expected " ++ show expected ++ " args; found " ++ unwordsList found
+showError (NumArgs expected found) = "Expected " ++ show expected ++ " arguments, received [" ++ unwordsList found ++ "]"
showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected ++ ", found " ++ show found
showError (Parser parseErr) = "Parse error at " ++ show parseErr

No commit comments for this range

Something went wrong with that request. Please try again.