参考URL
ソース
プリミティブの追加
「評価: 第一部」では加減乗除、商や余りを求める
プリミティブを定義しました。
ここでは更に追加のプリミティブを定義します。
("=", numBoolBinop (==)),
("<", numBoolBinop (<)),
(">", numBoolBinop (>)),
("/=", numBoolBinop (/=)),
(">=", numBoolBinop (>=)),
("<=", numBoolBinop (<=)),
("&&", boolBoolBinop (&&)),
("||", boolBoolBinop (||)),
("string=?", strBoolBinop (==)),
("string<?", strBoolBinop (<)),
("string>?", strBoolBinop (>)),
("string<=?", strBoolBinop (<=)),
("string>=?", strBoolBinop (>=)),
上記プリミティブの計算結果は全て真偽値になります。
numBoolBinop,boolBoolBinop,strBoolBinopの共通部分をまとめて
boolBinop関数に定義します。
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
boolBinopは
- (LispVal -> ThrowsError a)の型を持つ関数、
- (a -> a -> Bool)の型を持つ関数
- [LispVal]
を受け取って、
ThrowsError LispValを返します。
関数の実装をみていくと、まずargsの要素数が２かそうでないかを
調べます。
要素数が２でないならNumArgsエラーにして返却します。
要素数が２であるなら、それぞれの引数をunpacker関数に適用し、
結果をleft,rightに格納します。
unpacker関数に関しては、この後みていきます。
最後にleftとrightを真偽値を返す演算子に適用して、
BoolコンストラクタでLispValにしてThrowsErrorに包んで返します。
次にboolBinopを使ったそれぞれの関数をみてみます。
numBoolBinop = boolBinop unpackNum
strBoolBinop = boolBinop unpackStr
boolBoolBinop = boolBinop unpackBool
違いはunpackXXXのところだけです。
unpackNumは以前にすでに定義済みです。
unpackNum :: LispVal -> ThrowsError Integer
unpackNum (Number n) = return n
unpackNum (String n) = let parsed = reads n in
if null parsed
then throwError $ TypeMismatch "number" $ String n
else return $ fst $ parsed !! 0
unpackNum (List [n]) = unpackNum n
unpackNum notNum = throwError $ TypeMismatch "number" notNum
LispValをIntegerかエラーに変換します。
unpackStrも同様にLispValをStringかエラーに変換します。
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
単純にStringに変換できるものはStringに変換して、
変換できないものはエラーにしているだけです。
unpackBoolも簡単です。
unpackBool :: LispVal -> ThrowsError Bool
unpackBool (Bool b) = return b
unpackBool notBool = throwError $ TypeMismatch "boolean" notBool
Boolでなければエラーにしているだけです。
これで、大小比較や論理演算などが行えるようになりました。