「Write Yourself a Scheme in 48 Hours」 を写経してみる(7) : Equal? と弱いタイピング: 不均一なリスト

タイトルが長すぎるのが気になります・・・。

• Write Yourself a Scheme in 48 Hours/Evaluation, Part 2
• http://jonathan.tang.name/files/scheme_in_48/code/listing6.4.hs

まず、ghci listing6.4.hs とするとエラーになります。

$ ghci listing6.4.hs
GHCi, version 6.12.1: http://www.haskell.org/ghc/  :? for help
Loading package ghc-prim ... linking ... done.
Loading package integer-gmp ... linking ... done.
Loading package base ... linking ... done.
[1 of 1] Compiling Main             ( listing6.4.hs, interpreted )

listing6.4.hs:203:16:
    Not a data constructor: `forall'
    Perhaps you intended to use -XExistentialQuantification
Failed, modules loaded: none.

これは forall 拡張を使っているからのようで、listing6.4.hs の先頭に{-# LANGUAGE ExistentialQuantification #-}を記入すればOKでした。

{-# LANGUAGE ExistentialQuantification #-}

module Main where
import Monad
import System.Environment

forall は全く分かっていないのですが、必要に応じて読むことにします。
Haskell/Existentially quantified types
今回作成している scheme は拡張されたものであり、数値の演算に文字列が記入してあっても数値に変換して演算します。

>  eval =<< readExpr "(+ 2 \"2\")"       -- > Right 4

eqv? による比較は #f であっても equal?による比較は #t にしようと言う話です。

>  eval =<< readExpr "(eqv? 2 \"2\")"    -- > Right #f
>  eval =<< readExpr "(equal? 2 \"2\")"  -- > Right #t

比較するための関数を mapM により適用するために Unpacker 型が定義してあります。
うっ、分からない・・・。

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

unpackEquals は arg1とarg2 、LispValを数値、文字列、論理値に統一する関数を受け取ります。
受け取ったunpackerをarg1、arg2に適用させて比較した結果を返します。

unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool
unpackEquals arg1 arg2 (AnyUnpacker unpacker) = 
    do unpacked1 <- unpacker arg1 -- 引数で受け取った
       unpacked2 <- unpacker arg2 --  AnyUnpacker unpackerの関数を適用
       return $ unpacked1 == unpacked2 -- それを比較
  `catchError` (const $ return False)  -- エラーがあれば do 構文の結果を捨てて
                                       -- False を返す。

(equal? 2 "2") のときに呼ばれる関数はequalです。引数はLispVal型のリスト。
(unpackEquals arg1 arg2) を unpackNum, unpackStr, unpackBoolに適用してどれかが True になれば等しいと判定します。

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

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

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

-- 文字列は数値に統一して比較
>  (unpackEquals (Number 2) (String "2"))  (AnyUnpacker unpackNum)
-- > Right True
-- 数値は文字列に統一して比較
>  (unpackEquals (Number 2) (String "2"))  (AnyUnpacker unpackStr)
-- > Right True
-- 論理値は Bool b の Bool を外して比較
>  (unpackEquals (Number 2) (String "2"))  (AnyUnpacker unpackBool)
-- > Right False

equal 関数は[Number 2,String "2"]を受け取ります。
それぞれの unpackEquals を適用した値が True 、eqv 関数を適用した値は False 結果として True を返します。

> eval =<< readExpr "(equal? 2 \"2\")"
[arg1, arg2]:[Number 2,String "2"]
primitiveEquals:True eqvEquals:Bool False
Right (Bool True)

-- (Number 2) と (String "2") が実質等しいか、unpackNum, unpackStr, unpackBoolに適用します。
> mapM (unpackEquals (Number 2) (String "2")) [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
Right [True,True,False]

> :t mapM (unpackEquals (Number 2) (String "2")) [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
mapM (unpackEquals (Number 2) (String "2")) [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
  :: Either LispError [Bool]

-- 結果のリストを or してどれか True であれば等しい。
> liftM or $ mapM (unpackEquals (Number 2) (String "2")) [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
Right True

>  eval =<< readExpr "(equal? '(1 2 3) '(1 2 3))"
[arg1, arg2]:[List [Number 1,Number 2,Number 3],List [Number 1,Number 2,Number 3]]
primitiveEquals:False eqvEquals:Bool True
Right (Bool True)

戻って、Unpacker型。

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

[AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool]

unpackNum, unpackStr, unpackBool の返す型の違う関数がひとつのリストになっています。

unpackNum  :: LispVal -> ThrowsError Integer
unpackStr  :: LispVal -> ThrowsError String
unpackBool :: LispVal -> ThrowsError Bool

AnyUnpacker (LispVal -> ThrowsError a)の型変数 a は Eq であり、forall・・・。

data UnpacRet = ThrowsError Integer | ThrowsError String |ThrowsError Bool

unpackNum  :: LispVal -> UnpacRet
unpackStr  :: LispVal -> UnpacRet
unpackBool :: LispVal -> UnpacRet

のような意味？