Additional Primitives: Partial Application
This commit is contained in:
parent
8d534810b2
commit
4e160f41ed
1 changed files with 38 additions and 1 deletions
39
scheme.hs
39
scheme.hs
|
@ -136,6 +136,8 @@ apply func args = maybe (throwError $ NotFunction "Unrecognized primitive functi
|
|||
($ args)
|
||||
(lookup func primitives)
|
||||
|
||||
-- Primitives
|
||||
|
||||
primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
|
||||
primitives = [("+", numericBinop (+)),
|
||||
("-", numericBinop (-)),
|
||||
|
@ -143,7 +145,20 @@ primitives = [("+", numericBinop (+)),
|
|||
("/", numericBinop div),
|
||||
("mod", numericBinop mod),
|
||||
("quotient", numericBinop quot),
|
||||
("remainder", numericBinop rem)]
|
||||
("remainder", numericBinop rem),
|
||||
("=", numBoolBinop (==)),
|
||||
("<", numBoolBinop (<)),
|
||||
(">", numBoolBinop (>)),
|
||||
("/=", numBoolBinop (/=)),
|
||||
(">=", numBoolBinop (>=)),
|
||||
("<=", numBoolBinop (<=)),
|
||||
("&&", boolBoolBinop (&&)),
|
||||
("||", boolBoolBinop (||)),
|
||||
("string=?", strBoolBinop (==)),
|
||||
("string<?", strBoolBinop (<)),
|
||||
("string>?", strBoolBinop (>)),
|
||||
("string<=?", strBoolBinop (<=)),
|
||||
("string>=?", strBoolBinop (>=))]
|
||||
|
||||
numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
|
||||
numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
|
||||
|
@ -158,6 +173,28 @@ unpackNum (String n) = let parsed = reads n in
|
|||
unpackNum (List [n]) = unpackNum n
|
||||
unpackNum notNum = throwError $ TypeMismatch "number" notNum
|
||||
|
||||
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
|
||||
|
||||
-- Error checking
|
||||
data LispError = NumArgs Integer [LispVal]
|
||||
| TypeMismatch String LispVal
|
||||
|
|
Loading…
Reference in a new issue