参考URL

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

ソース

equal

型が違っても同じ評価値になるならば真を返すequal関数を実装します。
例としてString "2"とNumber 2の比較は真になります。

具体的にはこれまでに実装した、unpackNum,unpackStr,unpackBool
を対象のLispVal２つに適用して、
等しいものが一つでもあるか判定します。

方法として考えられるのはunpack系の関数をリストに入れて、
mapでLispValに適用する方法ですが、Haskellでは同じ型のものしか
リストに入れることができません。

そこで「言語拡張」を行い、異なる型でもリストにいれることが
できるようにします。

data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a)

これでEqのインスタンスであるa型なら全て同じUnpacker型として
扱えるようになります。

AnyUnpackerはUnpacker型を作るためのコンストラクタです。

equal関数実装の前に、Unpackerで包んだunpack系関数を渡して、
２つのLispValが等しいかどうか判定する関数を定義します。

unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
unpackEquals arg1 arg2 (AnyUnpacker unpacker) = 
             do unpacked1 <- unpacker arg1
                unpacked2 <- unpacker arg2
                return $ unpacked1 == unpacked2
        `catchError` (const $ return False)

Unpackerに包まれた(LispVal -> ThrowsError a)を
取り出して、２つのLispVal、arg1,arg2に適用して、
それを比較して返します。
catchError関数は直前の処理の結果がLeft値のときには
直後の関数にLeft値を適用し、
Right値の場合はそのまま返します。

> catchError (Left 2) (Right)
Right 2
> catchError (Left 2) (Left)
Left 2
> catchError (Right 3) (Left)
Right 3

constは２つの引数をとり、２つ目の引数がどんな値でも
１つ目の値を返す関数です。

> const 2 1
2
> const 2 4
2
> const "abc" 2
"abc"

そのため

(const $ return False)

は、cathError経由でどんな値が渡されようと、
必ずreturn Falseを返します。

最後にequal関数を定義します。

equal :: [LispVal] -> ThrowsError LispVal
equal [arg1, arg2] = do
    primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2) 
                      [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
    eqvEquals <- eqv [arg1, arg2]
    return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)
equal badArgList = throwError $ NumArgs 2 badArgList

まず、

mapM (unpackEquals arg1 arg2) 
                      [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]

の部分ですが、unpackEqualsにUnpacker以外を部分適用した状態にして
mapMでUnpackerのリストを順々に適用していきます。

結果としてThrowsError [Bool]が返るので、
その[Bool]に対しorを適用します。
[Bool]はThrowsErrorに包まれているので、中身に適用するために
liftM関数を使います。
結果として、primitiveEquals変数には真偽値が入ります。

次にeqv関数にarg1,arg2を適用します。

eqvEquals <- eqv [arg1, arg2]

eqv関数の結果はThrowsError LispValなので
eqvEqualsにはLispValが入ります。
env関数はLispValのBoolのみを返すので
envEqualsはBoolコンストラクタを適用した真偽値になります。

最後の

return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x)

の中の

let (Bool x) = eqvEquals in x)

ではLispValのBoolを外した真偽値を返しています。
その結果とprimitiveEqualsとのorを取って、
その結果をBoolコンストラクタに適用してreturnで
ThrowsError LispValにします。

リストの要素が２つ以外でequal関数を呼ばれた場合は
エラーにしています。

最後にprimitivesにこれまで作った関数を
追加して、評価:第二部を終了します。

              ("car", car),
              ("cdr", cdr),
              ("cons", cons),
              ("eq?", eqv),
              ("eqv?", eqv),
              ("equal?", equal)]