参考URL

48時間でSchemeを書こう/評価: 第二部

ソース

プリミティブの追加

「評価: 第一部」では加減乗除、商や余りを求める
プリミティブを定義しました。
ここでは更に追加のプリミティブを定義します。

("=", 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でなければエラーにしているだけです。

これで、大小比較や論理演算などが行えるようになりました。