人気ブログランキング | 話題のタグを見る

ラムダ計算プログラム(最終版)

前回のラムダ計算プログラムで評価エラーのときはプログラムがストップしていたのを、エラーメッセージを表示して継続するように変更した。疲れたのでこれが最終版。コマンドラインからインタラクティブに自作のプログラムをコントロールする手順がわかったような気がする。次の4段階に区分してプログラムを作るとよいようだ。

1.自作プログラム言語のモデルを作る。本プログラムの Exp データ構造がそれに当たる。記号論で言う構文論だ。
2.モデルの評価プログラムを作る。本プログラムの eval 関数。記号論で言う意味論。
3.入力のインターフェースとしてパーサを作る。これに Parsec を使う。パーサは意外に出番が多い。
4.コマンドライン編集ができるように System.Console.Haskeline を利用する。コマンドラインでの入力の編集は必須。

この4つの層は結合がゆるいので、モジュールに分離してモジュラーなプログラムにすることができる。つまりそれぞれの層のプログラムを再利用可能であるということだ。

自作のプログラムを作ったときに各機能をコマンドラインで結合して使いたいときがよくある。上の4つの層をもつプログラムをひとつ作ってみれば、そのようなときに使いまわしが可能なような気がする。

最終盤は lambda2.hs という名前のファイルに作成した。一本のプログラムにせずにモジュールにすればよかったかもしれない。デバッグが随分楽になる。プログラムの使い方は次のようになる。ラムダ記号は l (小文字のl)で代用している。ラムダ抽象とボディの部分はコロンで区切る。また、式は必ず括弧でくくる。

$ runghc lambda2.hs
lambda> (* (+ 1 2) (+ 3 4))
Right (Mul (Plus (Lit 1) (Lit 2)) (Plus (Lit 3) (Lit 4)))
IntVal 21
lambda> (= f (lx.(+ x x)))
Right (Bind "f" (Abs "x" (Plus (Var "x") (Var "x"))))
lambda> (f 3)
Right (App (Var "f") (Lit 3))
IntVal 6
lambda> ((lx.(x x)) (lx.x))
Right (App (Abs "x" (App (Var "x") (Var "x"))) (Abs "x" (Var "x")))
FunVal (fromList [("f",FunVal (fromList []) "x" (Plus (Var "x") (Var "x")))]) "x" (Var "x")
lambda> (((lx.(x x)) (lx.x)) 2)
Right (App (App (Abs "x" (App (Var "x") (Var "x"))) (Abs "x" (Var "x"))) (Lit 2))
IntVal 2
lambda> quit

ソースは次のようになる。

ファイル名:lambda2.hs

module Transformers where
import Control.Monad.Identity
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Trans

import Data.Maybe
import Data.IORef
import qualified Data.Map as Map

import System.Console.Haskeline
import Text.Parsec

type Name = String
data Exp = Lit Integer
........ | Var Name
........ | Plus Exp Exp
........ | Sub Exp Exp
........ | Mul Exp Exp
........ | Div Exp Exp
........ | Mod Exp Exp
........ | Abs Name Exp
........ | App Exp Exp
........ | Bind Name Exp
........ deriving (Show)
data Value = IntVal Integer
.......... | FunVal Env Name Exp
.......... deriving (Show)

type Env = Map.Map Name Value

type Eval2 a = ExceptT String Identity a
runEval2 :: Eval2 a -> Either String a
runEval2 ev = runIdentity (runExceptT ev)

eval2..................:: Env -> Exp -> Eval2 Value
eval2 env (Lit i)......= return $ IntVal i
eval2 env (Var n)......= case Map.lookup n env of
.......................... Nothing -> throwError ("unbound variable: " ++ n)
.......................... Just val -> return val
eval2 env (Plus e1 e2) = do e1' <- eval2 env e1
............................e2' <- eval2 env e2
............................case (e1', e2') of
..............................(IntVal i1, IntVal i2) ->
................................ return $ IntVal (i1 + i2)
.............................._ -> throwError "type error in addition"
eval2 env (Sub e1 e2) = do e1' <- eval2 env e1
.......................... e2' <- eval2 env e2
.......................... case (e1', e2') of
..............................(IntVal i1, IntVal i2) ->
................................ return $ IntVal (i1 - i2)
.............................._ -> throwError "type error in subtraction"
eval2 env (Mul e1 e2) = do e1' <- eval2 env e1
.......................... e2' <- eval2 env e2
.......................... case (e1', e2') of
..............................(IntVal i1, IntVal i2) ->
................................ return $ IntVal (i1 * i2)
.............................._ -> throwError "type error in multiplication"
eval2 env (Div e1 e2) = do e1' <- eval2 env e1
.......................... e2' <- eval2 env e2
.......................... case (e1', e2') of
..............................(IntVal i1, IntVal i2) ->
................................ return $ IntVal (i1 + i2)
.............................._ -> throwError "type error in division"
eval2 env (Abs n e)....= return $ FunVal env n e
eval2 env (App e1 e2)..= do val1 <- eval2 env e1
............................val2 <- eval2 env e2
............................case val1 of
..............................FunVal env' n body ->
................................eval2 (Map.insert n val2 env') body
.............................._ -> throwError "type error in application"

exampleExp = Lit 12 `Plus` (App (Abs "x" (Var "x")) (Lit 4 `Plus` Lit 2))

expr :: Parsec String () Exp
expr = lit <|> var <|> plus <|> minus <|> mul <|> divide <|> abstr <|> app <|> bnd
..where
....lit = try (do i <- many1 digit; spaces; return $ Lit ((read :: String -> Integer) i))
....var = try (do x <- many1 letter; spaces; return (Var x))
....plus = try (do string "(+"; spaces; x <- expr; y <- expr; string ")"; spaces; return (Plus x y))
....minus = try (do string "(-"; spaces; x <- expr; y <- expr; string ")"; spaces; return (Sub x y))
....mul = try (do string "(*"; spaces; x <- expr; y <- expr; string ")"; spaces; return (Mul x y))
....divide = try (do string "(div"; spaces; x <- expr; y <- expr; string ")"; spaces; return (Div x y))
....abstr = try (do string "(l"; x <- many1 letter;..string "."; y <- expr; string ")"; spaces; return (Abs x y))
....app = try (do string "("; spaces; x <- expr; y <- expr; string ")"; spaces; return (App x y))
....bnd = try (do string "(="; spaces; x <- many1 letter; spaces; y <- expr; string ")"; spaces; return (Bind x y))

parseExp :: String -> Either ParseError Exp
parseExp input = parse expr "lambda expression" input

main :: IO ()
main = do
..global <- newIORef Map.empty
..runInputT defaultSettings (loop global)
....where
......loop :: (IORef (Map.Map Name Value)) -> InputT IO ()
......loop global = do
........minput <- getInputLine "lambda> "
........case minput of
..........Nothing -> return ()
..........Just "quit" -> return ()
..........Just input -> do
............expression <- return $ parseExp input
............lift $ putStrLn (show expression)
............env <- lift $ readIORef global
............case expression of
.............. Right (Bind x e) -> do
................ let Right val = runEval2 (eval2 env e)
................ lift $ writeIORef global (Map.insert x val env)
.............. Right exp -> let val = runEval2 (eval2 env exp)
............................in case val of
.............................. Right value ->
................................ outputStrLn $ show value
.............................. Left err ->
................................ outputStrLn $ show err
.............. Left err -> outputStrLn $ show err
............loop global

by tnomura9 | 2019-09-01 00:00 | Haskell | Comments(0)
<< Inside Parsec ラムダ計算プログラム >>