「Write Yourself a Scheme in 48 Hours」を写経してみる(15) : 基本 IO の作成。

Haskellはこれが最後のファイルです。

-- forall でエラーにならないように先頭に記入しておきます。
{-# LANGUAGE ExistentialQuantification #-}

-- 保存された変数を表示するための関数
showEnv :: IORef [(String, IORef LispVal)] -> IO [(String, LispVal)]
showEnv envRef = readIORef envRef >>= flip readLS []
    where
        readLS :: [(String, IORef LispVal)] -> [(String, LispVal)] -> IO [(String, LispVal)]
        readLS []     out = return out
        readLS (x:xs) out = readTuple x >>= \tuple -> readLS xs (tuple:out)

        readTuple :: (String, IORef LispVal) -> IO (String, LispVal)
        readTuple tuple = readIORef (snd tuple)>>= \val -> return (fst tuple,val)

wikibooksは LispValの型の追加からですが、こちらは main から見ています。

main :: IO ()
main = do args <- getArgs
          if null args then runRepl else runOne $ args

プログラムを起動するときの引数がないときはrunRepl(Read-eval-print loop)。
引数があれば runOne です。

runOne :: [String] -> IO ()
runOne args = do
    env <- primitiveBindings >>= flip bindVars [("args", List $ map String $ drop 1 args)] 
    (runIOThrows $ liftM show $ eval env (List [Atom "load", String (args !! 0)])) 
         >>= hPutStrLn stderr

まず、do 記法です。scheme の持つ基本関数が環境に書き込まれ、bindVarsに渡されます。

> env <- primitiveBindings >>= flip bindVars [("args", List $ map String $ drop 1 ["test.scm"])]
> showEnv env
[("equal?",<primitive>),("eqv?",<primitive>),("eq?",<primitive>),("cons",<primitive>),
 ("cdr",<primitive>),("car",<primitive>),("string>=?",<primitive>),("string<=?",<primitive>),
 ("string?",<primitive>),("string=?",<primitive>),("||",<primitive>),("&&",<primitive>),
 ("<=",<primitive>),(">=",<primitive>),("/=",<primitive>),(">",<primitive>),("<",<primitive>),
 ("=",<primitive>),("remainder",<primitive>),("quotient",<primitive>),("mod",<primitive>),
 ("/",<primitive>),("*",<primitive>),("-",<primitive>),("+",<primitive>),
 -- ここから新たに追加された関数
 ("read-all",<IO primitive>),
 ("read-contents",<IO primitive>),
 ("write",<IO primitive>),
 ("read",<IO primitive>),
 ("close-output-port",<IO primitive>),
 ("close-input-port",<IO primitive>),
 ("open-output-file",<IO primitive>),
 ("open-input-file",<IO primitive>),
 ("apply",<IO primitive>),
 ("args",())]

引数が一個のときは、最後は ("args",())のように"args"は空ですが、引数となったプログラムが引数を持つときは"args"にリストとして保持されます。

評価の段階で (load fileName) のパターンが追加されています。

eval env (List [Atom "load", String filename]) = 
    load filename >>= liftM last . mapM (eval env)

$ cat test.scm
(define (add x y) (+ x y))
(add 10 20)

(load "test.scm")を行うことにより test.scmの中で定義されているadd 関数が使用できるようになります。

Lisp>>> (load "test.scm")
30
Lisp>>> (add 100 200)
300

> (runIOThrows $ liftM show $ eval env (List [Atom "load", String (["test.scm"] !! 0)]))
"30"

(List [Atom "load", String (["test.scm"] !! 0)])が評価されると次のパターンにマッチします。
load 関数を見ていきます。
load は filename のファイルを読み込んで liftIO の後に、モナド経由でliftThrows . readExprListに渡されます。

load :: String -> IOThrowsError [LispVal]
load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList

liftIO をしないでそのまま渡してみます。

> readFile "test.scm" >>= (liftThrows . readExprList)

<interactive>:1:25:
    Couldn't match expected type `IO b'
           against inferred type `IOThrowsError [LispVal]'

型が合いません。

> :t (liftThrows . readExprList)
(liftThrows . readExprList) :: String -> IOThrowsError [LispVal]
-- (liftThrows . readExprList) は　String を受け取って IOThrowsError [LispVal]を返します。

> :t readFile "test.scm"
-- > readFile "test.scm" :: IO String
-- readFile　は IO 型のモナドを返しますから、>>= の左と右ではモナドの型が違うのです。

-- そこで liftIOによって MonadIO に変換します。
> :t liftIO 
-- > liftIO :: MonadIO m => IO a -> m a

> :t liftIO $ readFile "test.scm"
-- > liftIO $ readFile "test.scm" :: MonadIO m => m String

> (liftIO $ readFile "test.scm") >>=  \x-> runIOThrows $ liftM show $ liftThrows $ readExprList x
 -- > "[(define (add x y) (+ x y)),(add 10 20)]"

MonadIO クラスについてはモナドのすべて Haskell におけるモナドプログラミングの理論と実践に関する包括的ガイド・標準モナド変換子に記述があります

多段もちあげ

scheme が最初から持っている関数を環境に書き込む primitiveBindings がlisting10.hsでは変更になっています。

-- listing9.hs
primitiveBindings :: IO Env
primitiveBindings = nullEnv >>= (flip bindVars $ map makePrimitiveFunc primitives)
    where makePrimitiveFunc (var, func) = (var, PrimitiveFunc func)

-- listing10.hs
primitiveBindings :: IO Env
primitiveBindings = nullEnv >>= (flip bindVars $ map (makeFunc IOFunc) ioPrimitives
                                              ++ map (makeFunc PrimitiveFunc) primitives)
    where makeFunc constructor (var, func) = (var, constructor func)

primitives の要素にmakePrimitiveFuncを適用して出来たFunc型を初期化した環境に書き込むだけでしたが、makePrimitiveFuncは(makeFunc PrimitiveFunc)に変更になり、(makeFunc IOFunc) ioPrimitivesが追加されています。