「Write Yourself a Scheme in 48 Hours」 を写経してみる(6) : 評価その２

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

primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives = [("+", numericBinop (+)),
              ("-", numericBinop (-)),
              ("*", numericBinop (*)),
              ("/", numericBinop div),
              ("mod", numericBinop mod),
              ("quotient", numericBinop quot),
              ("remainder", numericBinop rem),
              ("=", numBoolBinop (==)),         -- ここから追加されました。
              ("<", numBoolBinop (<)),
              (">", numBoolBinop (>)),
              ("/=", numBoolBinop (/=)),
              (">=", numBoolBinop (>=)),
              ("<=", numBoolBinop (<=)),
              ("&&", boolBoolBinop (&&)),
              ("||", boolBoolBinop (||)),
              ("string=?", strBoolBinop (==)),
              ("string?", strBoolBinop (>)),
              ("string<=?", strBoolBinop (<=)),
              ("string>=?", strBoolBinop (>=)),
              ("car", car),
              ("cdr", cdr),
              ("cons", cons),
              ("eq?", eqv),
              ("eqv?", eqv)]                 -- ここまで

-- > readExpr "(+ 1)" >>= eval     -- > Left Expected 2 args; found values 1
-- > readExpr "(+ 1 2 3)" >>= eval -- > Right (Number 6)
numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal
numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op

-- "=","<",">","/=",">=","<=" の演算
-- 引数の数が2以外はエラー
-- > readExpr "(= 1 2 3)" >>= eval -- > Left Expected 2 args; found values 1 2 3
boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBinop unpacker op args = if length args /= 2 
                             then throwError $ NumArgs 2 args     -- 引数の数が2以外はエラー
                             else do left <- unpacker $ args !! 0  -- 左側の引数
                                     right <- unpacker $ args !! 1  -- 右側の引数
                                     return $ Bool $ left `op` right --  左側の引数 `op` 右側の引数

-- Integer の "=","<",">","/=",">=","<=" の演算
{- 
> readExpr "(= 123 123)" >>= eval      -- > Right #t
> readExpr "(= 123 0)" >>= eval        -- > Right #f
> readExpr "(> 123 0)" >>= eval        -- > Right #t
> readExpr "(< 123 0)" >>= eval        -- > Right #f
> readExpr "(>= 123 123)" >>= eval     -- > Right #t
> readExpr "(>= 123 122)" >>= eval     -- > Right #t
> readExpr "(>= 123 124)" >>= eval     -- > Right #f
-}
numBoolBinop :: (Integer -> Integer -> Bool) -> [LispVal] -> ThrowsError LispVal
numBoolBinop = boolBinop unpackNum

-- String の string=?, string<=?, string>=?  の演算
{-
> readExpr "(string=? \"hello\" \"hello\")" >>= eval  -- > Right #t
> readExpr "(string<=? \"hello\" \"hello\")" >>= eval -- > Right #t
> readExpr "(string<=? \"hello\" \"hellp\")" >>= eval -- > Right #t
> readExpr "(string<=? \"hello\" \"helln\")" >>= eval -- > Right #f
> readExpr "(string>=? \"hello\" \"helln\")" >>= eval -- > Right #t
> readExpr "(string>=? \"hello\" \"hellp\")" >>= eval -- > Right #f
-}
strBoolBinop :: (String -> String -> Bool) -> [LispVal] -> ThrowsError LispVal
strBoolBinop = boolBinop unpackStr

-- Bool の &&, || の演算
{-
> readExpr "(&& #t #t)" >>= eval           -- > Right #t
> readExpr "(&& #t #f)" >>= eval           -- > Right #f
> readExpr "(|| #t #f)" >>= eval           -- > Right #t
> readExpr "(|| #f #f)" >>= eval           -- > Right #f
> readExpr "(|| #f (= 123 123))" >>= eval  -- > Right #t
-}
boolBoolBinop :: (Bool -> Bool -> Bool) -> [LispVal] -> ThrowsError LispVal
boolBoolBinop = boolBinop unpackBool

{-
> map unpackNum [Number 1,Number 2,Number 3]    -- > [Right 1,Right 2,Right 3]
> mapM unpackNum [Number 1,Number 2,Number 3]   -- > Right [1,2,3]
> mapM unpackNum [Number 1,Number 2,String "3"] -- > Right [1,2,3]
> :t mapM
mapM :: (Monad m) => (a -> m b) -> [a] -> m [b]
> :t map
map :: (a -> b) -> [a] -> [b]
-}
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
{-
> mapM unpackNum [Number 1,Number 2,List [Number 3]] -- > Right [1,2,3]
-}
unpackNum (List [n]) = unpackNum n
{-
> mapM unpackNum [String "one"]
-- > Left Invalid type: expected number, found String "one"
-}
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

if 文の評価
eval のパターンマッチに if 文の評価を加えます。

eval (List [Atom "if", pred, conseq, alt]) = 
    do result <- eval pred     -- if の次のリスト要素を評価した結果
       case result of
         Bool False -> eval alt    -- Bool False のときは alt を実行
         otherwise  -> eval conseq -- それ以外は conseqを 実行

> readExpr "(if (> 2 3) \"no\" \"yes\")" 
Right (List [Atom "if", 
                  List [Atom ">",Number 2,Number 3], 
                  String "no",
                  String "yes"]) -- こちらが返される。

-- List [Atom ">",Number 2,Number 3] の評価結果は(Bool False)
> eval (List [Atom ">",Number 2,Number 3]) --> Right (Bool False)

ghci>  readExpr "(if (> 2 3) \"no\" \"yes\")" >>= eval  
-- > Right (String "yes")

ghci>  readExpr  "(if (= 3 3) (+ 2 3 (- 5 1)) \"unequal\")" 
Right (List [Atom "if",
             List [Atom "=",Number 3,Number 3], -- 評価結果は True
             List [Atom "+",Number 2,Number 3,  -- (+ 2 3 4)・・・9
                   List [Atom "-",Number 5,Number 1]], -- (- 5 1):5-1つまり4
             String "unequal"])

-- > Right (Number 9)

car 文の評価

car :: [LispVal] -> ThrowsError LispVal
car [List (x : xs)] = return x
-- readExpr "(car '(1 2 3))" >>= eval     -- > Right (Number 1)
-- readExpr "(car '(1))" >>= eval         -- > Right (Number 1)

car [DottedList (x : xs) _] = return x
-- readExpr "(car '(1 . 2))" >>= eval     -- > Right (Number 1)

car [badArg] = throwError $ TypeMismatch "pair" badArg
--  readExpr "(car '())" >>= eval -- > Left Invalid type: expected pair, found List []
-- readExpr "(car 123)" >>= eval  -- > Left Invalid type: expected pair, found Number 123

car badArgList = throwError $ NumArgs 1 badArgList
-- readExpr "(car '123 '456)" >>= eval
   -- > Left Expected 1 args; found values 123 456
-- readExpr "(car '(123 456) '(3 5))" >>= eval
   -- > Left Expected 1 args; found values (123 456) (3 5)

cdr 文の評価

cdr :: [LispVal] -> ThrowsError LispVal
cdr [List (x : xs)] = return $ List xs
cdr [DottedList (_ : xs) x] = return $ DottedList xs x
cdr [DottedList [xs] x] = return x
cdr [badArg] = throwError $ TypeMismatch "pair" badArg
cdr badArgList = throwError $ NumArgs 1 badArgList

>  readExpr "(cdr '(1 2 3))" 
-- > Right (List [Atom "cdr",List [Atom "quote",List [Number 1,Number 2,Number 3]]])
>  eval =<< readExpr "(cdr '(1 2 3))" 
-- > Right (List [Number 2,Number 3])
>  eval =<< Right (List [Atom "quote",List [Number 1,Number 2,Number 3]])
-- > Right (List [Number 1,Number 2,Number 3])
>  eval =<< readExpr "(cdr '(1 2))" 
-- > Right (List [Number 2])
>  eval =<< readExpr "(cdr '(1))" 
-- > Right (List [])

>  eval =<< readExpr "(cdr '(1 . 2))" 
-- > Right (DottedList [] (Number 2))
>  eval =<< readExpr "(cdr '(1 2 3 .  4))" 
-- > Right (DottedList [Number 2,Number 3] (Number 4))
>  eval =<< readExpr "(cdr '(1 .  2))" 
-- > Right (DottedList [] (Number 2))
>  eval =<< readExpr "(cdr '(x .  2))" 
-- > Right (DottedList [] (Number 2))
>  readExpr "(cdr '(x .  2))" 
-- >Right (List [Atom "cdr",List [Atom "quote",DottedList [Atom "x"] (Number 2)]])

>  readExpr "(cdr '123)" 
-- > Right (List [Atom "cdr",List [Atom "quote",Number 123]])

>  eval =<< readExpr "(cdr '123)" 
-- > Left Invalid type: expected pair, found Number 123
>  eval =<< readExpr "(cdr '(1 2) '(a b))" 
-- > Left Expected 1 args; found values (1 2) (a b)

cons 文の評価

cons :: [LispVal] -> ThrowsError LispVal
cons [x1, List []] = return $ List [x1]
cons [x, List xs]  = return $ List $ [x] ++ xs
cons [x, DottedList xs xlast] = return $ DottedList ([x] ++ xs) xlast
cons [x1, x2]      = return $ DottedList [x1] x2
cons badArgList    = throwError $ NumArgs 2 badArgList

>  readExpr "(cons 1 2)" 
-- > Right (List [Atom "cons",Number 1,Number 2])
>  eval =<< readExpr "(cons 1 2)" 
-- > Right (DottedList [Number 1] (Number 2))
>  eval =<< readExpr "(cons 1 '())" 
-- > Right (List [Number 1])
>  readExpr "(cons 1 '())" 
-- > Right (List [Atom "cons",Number 1,List [Atom "quote",List []]])
>  eval =<< readExpr "(cons 1 '())" 
-- > Right (List [Number 1])
>  eval =<< readExpr "(cons 1 (cons 2 '()))" 
-- > Right (List [Number 1,Number 2])
>  eval =<< readExpr "(cons 1 (cons 2 3))" 
-- > Right (DottedList [Number 1,Number 2] (Number 3))
>  eval =<< readExpr "(cons '(1 2) '(a b))" 
-- > Right (List [List [Number 1,Number 2],Atom "a",Atom "b"])
>  eval =<< readExpr "(cons '(1 2) '(a . b))" 
-- > Right (DottedList [List [Number 1,Number 2],Atom "a"] (Atom "b"))
>  eval =<< readExpr "(cons 1 2)" 
-- > Right (DottedList [Number 1] (Number 2))

>  eval =<< readExpr "(cons 1)" 
-- > Left Expected 2 args; found values 1
>  eval =<< readExpr "(cons 1 2 3)" 
-- > Left Expected 2 args; found values 1 2 3

eq? eqv? 文の評価
eq? も eqv? も同じ eqvを呼んでいるので結果は同じです。
（本来のscheme は使い分けが必要です。「eq? eqv? equal? の使い分け」）

primitives :: [(String, [LispVal] -> ThrowsError LispVal)]
primitives = [("+", numericBinop (+)),
              〜〜〜〜
              ("eq?",  eqv),  -- 同じ eqvを呼んでいる 
              ("eqv?", eqv)]  -- 同じ eqvを呼んでいる

eqv 関数は内部では Haskell が動作して比較していますから、深くネストされたリストの内部まで照合します。

eqv :: [LispVal] -> ThrowsError LispVal
eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2
eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2
eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2
eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2
eqv [(DottedList xs x), (DottedList ys y)] = eqv [List $ xs ++ [x], List $ ys ++ [y]]
-- List の長さが同じであり、かつ、arg1 arg2をzipした各要素を比較して、その結果のAND。
eqv [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) && 
                                                    (and $ map eqvPair $ zip arg1 arg2)
    where eqvPair (x1, x2) = case eqv [x1, x2] of
                               Left err -> False
                               Right (Bool val) -> val
eqv [_, _] = return $ Bool False
eqv badArgList = throwError $ NumArgs 2 badArgList


> eval =<< readExpr "(eqv? 1 2)"                 -- > Right (Bool False)
> eval =<< readExpr "(eq? #t #t)"                -- > Right (Bool True)
> eval =<< readExpr "(eqv? 1 1)"                 -- > Right (Bool True)
> eval =<< readExpr "(eq? 1 1)"                  -- > Right (Bool True)
> eval =<< readExpr "(eqv? \"abc\" \"abc\")"  -- > Right (Bool True)
> eval =<< readExpr "(eq? \"abc\" \"abc\")"   -- > Right (Bool True)

> eval =<< readExpr "(eq? '(\"abc\" 2) '(\"abc\"))"   -- > Right (Bool False)
> eval =<< readExpr "(eq? '(\"abc\" 2) '(\"abc\" 2))" -- > Right (Bool True)

-- 内部はHaskell だから深いネストでも比較出来る。
> eval =<< readExpr "(eqv? '(\"abc\" 2 '(a b c)) '(\"abc\" 2 '(a b c)))"
-- > Right (Bool True)
> eval =<< readExpr "(eqv? '(\"abc\" 2 '(a b c)) 1)"
-- > Right (Bool False)

-- エラーテスト
> eval =<< readExpr "(eqv? '(\"abc\" 2 '(a b c)))"
-- > Left Expected 2 args; found values ("abc" 2 (quote (a b c)))
> eval =<< readExpr "(eqv? 1 2 3)"
-- > Left Expected 2 args; found values 1 2 3