Hatena::Grouphaskell

mokeheheの日記

2009-08-05

ラムダ関数を追加する

電卓で任意の型の値を扱えるようにする - mokeheheの日記 - haskellで関数をファーストクラスの値として扱えるようになったので、関数に渡したりできる:

> twice f x = f (f x)
<function>
> sq x = x * x
<function>
> twice sq 10
10000.0

でもグローバル関数しかないので、環境とかなにも考えなくてすんでいた。

ラムダ関数を追加しようとすると、レキシカルな環境のチェーンを作る必要がある。その場合にHaskellでどう実装したもんかとはたと困った。電卓には代入があるので環境の値が書き換えられる可能性があるので、IORefみたいに書き換えられるデータ型を使う必要があるのか?でも構文木の評価はStateモナドで行っていて、その中でIORefは使えるのか?

ちょっと難しいので、とりあえず後からの書き換えは考えず、たんに環境のチェーンだけを行ってクロージャを作れるようにしてみる。

まずはパーサにラムダ式を追加する。Haskellのラムダ式の形式「\args -> body」で:

factor = lambda <|> try(funcall) <|> primFactor

lambda = do
	lexeme $ char '\\'
	args <- many1 identifier
	lexeme $ string "->"
	e <- expr
	return $ Lambda args e

評価器の変更として、まず環境に親環境を追加:

data Environment = Environment Dictionary (Maybe Environment)

ラムダ式が出てきたときに、関数の生成にその文脈の環境を保持するように渡す:

eval (Lambda args body) = do
	st <- get
	let func = Function args body $ curenv st
	return func

関数呼び出し時は、関数のレキシカル環境を関数への実引数で拡張して本体呼び出し:

call fnode (Function args body env) params =do
	st <- get
	put $ st { curenv = Just (extend args params env) }
	res <- eval body
	put st
	return res

テスト:

> make_adder x = \y -> x + y
<function>
> twice (make_adder 1) 100
102.0

以下ソース:

Main.hs
import Prelude hiding (catch)
import Control.Exception (catch)
import Text.ParserCombinators.Parsec (runParser, eof)
import System.IO

import Parser (stmt)
import Intp (intp, IntpState(..), Value(..), emptyDictionary, doAssign, Environment(..))

repl :: String -> (String -> Bool) -> (String -> st -> (String, st)) -> st -> IO st
repl prompt bQuit eval = loop
	where
		loop st = hSetBuffering stdout NoBuffering >> putStr prompt >> getLine >>= act st
		act st s
			| bQuit s = return st
			| otherwise = catch (exec st s) (\exc -> print exc >> loop st)
		exec st s = do
			let (res, st') = eval s st
			putStrLn res
			loop st'

calc :: IntpState -> IO IntpState
calc = repl "> " (== ":q") parse
	where
		parse line st     = either (\err -> (show err, st)) (evaluate st) $ runParser parser () "" line
		evaluate st node  = result $ intp node st
		result (res, st)  = (show res, st)
		parser = stmt >>= \e -> eof >> return e

-- 初期の状態
initialState = IntpState dic Nothing
	where
		dic =
			doAssign "pi"    (DDouble pi) $
			doAssign "true"  (DBool True) $
			doAssign "false" (DBool False) $
			doAssign "sin"   (Native 1 (apply1 sin)) $
			doAssign "cos"   (Native 1 (apply1 cos)) $
			doAssign "tan"   (Native 1 (apply1 tan)) $
			doAssign "log"   (Native 1 (apply1 log)) $
			doAssign "sqrt"  (Native 1 (apply1 sqrt)) $
			emptyDictionary
		apply1 f = \[x] -> f x

main = putStrLn "type ':q' to quit." >> calc initialState >> putStrLn "Bye"
Parser.hs
limiter
Intp.hs
module Intp (
	intp,
	IntpState(..),
	emptyDictionary,
	doAssign,
	Environment(..),
	Value(..)
) where

import Prelude hiding (EQ, LT, GT)
import Parser (Node(..), Op(..))
import Control.Monad.State

-- 値
data Value =
		DDouble Double                      -- 直値
	|	DBool Bool                          -- 真偽値
	|	Function [String] Node (Maybe Environment)  -- 関数
	|	Native Int ([Double] -> Double)     -- ネイティブ関数

instance Show Value where
	show (DDouble d)        = show d
	show (DBool True)       = "true"
	show (DBool False)      = "false"
	show (Function _ _ _)   = "<function>"
	show (Native _ _)       = "<native>"

instance Eq Value where
	(DDouble d1) == (DDouble d2)  = d1 == d2
	(DBool   b1) == (DBool   b2)  = b1 == b2
	_           == _              = False

instance Ord Value where
	(DDouble d1) <  (DDouble d2)  = d1 <  d2
	(DBool   b1) <  (DBool   b2)  = b1 <  b2
	(DDouble d1) <= (DDouble d2)  = d1 <= d2
	(DBool   b1) <= (DBool   b2)  = b1 <= b2
	(DDouble d1) >  (DDouble d2)  = d1 >  d2
	(DBool   b1) >  (DBool   b2)  = b1 >  b2
	(DDouble d1) >= (DDouble d2)  = d1 >= d2
	(DBool   b1) >= (DBool   b2)  = b1 >= b2

-- 辞書
type Dictionary = [(String, Value)]

emptyDictionary :: Dictionary
emptyDictionary = []

doAssign :: String -> Value -> Dictionary -> Dictionary
doAssign var val dic = (var, val) : filter ((/= var) . fst) dic

-- 環境
data Environment = Environment Dictionary (Maybe Environment)
	deriving (Show)

-- 最初の値がJustだったらその値、Nothingだったら次の値を返す
orMaybe :: Maybe a -> Maybe a -> Maybe a
Just v  `orMaybe` _     = Just v
Nothing `orMaybe` alter = alter

-- 変数の参照
refvar :: String -> IntpState -> Maybe Value
refvar name st = lookupFromLocal `orMaybe` lookupFromGlobal
	where
		lookupFromLocal  = curenv st >>= search
		lookupFromGlobal = lookup name (global st)
		search (Environment dic parent_env) =
			lookup name dic `orMaybe` (parent_env >>= search)

-- インタプリタの状態
data IntpState =
	IntpState {
		global :: Dictionary,
		curenv :: Maybe Environment
		}
	deriving (Show)

assignCurrentEnv :: String -> Value -> IntpState -> IntpState
assignCurrentEnv name v st =
	case (curenv st) of
		Just (Environment dic parent_env) -> st { curenv = Just (Environment (doAssign name v dic) parent_env) }
		Nothing -> st { global = doAssign name v (global st) }

-- インタープリト
intp :: Node -> IntpState -> (Value, IntpState)
intp node state = runState (eval node) state


---------------------------------------
-- Intp

false   = DBool False
true    = DBool True
isFalse = (== false)
isTrue  = (/= false)

type MyST a = State IntpState a

eval :: Node -> MyST Value
eval (Literal v)      = return $ DDouble v
eval (Arith op n1 n2) = arith op n1 n2
eval (Ident name) = do
	st <- get
	case (refvar name st) of
		Nothing -> fail $ "undefined variable: " ++ name
		Just v  -> return v
eval (Assign name n) = do
	v <- eval n
	modify $ assignCurrentEnv name v
	return v
eval (If c t e) = do
	v <- eval c
	eval $ if isTrue v then t else e
eval (Funcall fnode params) = do
	fval <- eval fnode
	evaledParams <- evalNodeList params
	call fnode fval evaledParams
eval (Defun name args body) = do
	st <- get
	let func = Function args body $ curenv st
	modify $ assignCurrentEnv name func
	return func
eval (Lambda args body) = do
	st <- get
	let func = Function args body $ curenv st
	return func

arith Add     n1 n2 = evalArith (+)  n1 n2
arith Sub     n1 n2 = evalArith (-)  n1 n2
arith Mul     n1 n2 = evalArith (*)  n1 n2
arith Div     n1 n2 = evalArith (/)  n1 n2
arith Pow     n1 n2 = evalArith (**) n1 n2
arith EQ      n1 n2 = evalEq    (==) n1 n2
arith NE      n1 n2 = evalEq    (/=) n1 n2
arith LT      n1 n2 = evalOrd   (<)  n1 n2
arith LE      n1 n2 = evalOrd   (<=) n1 n2
arith GT      n1 n2 = evalOrd   (>)  n1 n2
arith GE      n1 n2 = evalOrd   (>=) n1 n2
arith LogiAnd n1 n2 = evalShortcut isFalse n1 n2
arith LogiOr  n1 n2 = evalShortcut isTrue  n1 n2
arith Negate  n1 n2 = evalArith (-)  n1 n2

evalArith op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	case (v1, v2) of
		(DDouble d1, DDouble d2) -> return $ DDouble $ d1 `op` d2
		_                        -> fail "illegal operation"
evalEq op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	return $ DBool $ v1 `op` v2
evalOrd op n1 n2 = do
	v1 <- eval n1
	v2 <- eval n2
	case (v1, v2) of
		(DDouble _, DDouble _) -> return $ DBool $ v1 `op` v2
		(DBool   _, DBool   _) -> return $ DBool $ v1 `op` v2
		_                      -> fail "illegal operation"
evalShortcut f n1 n2 = do
	v1 <- eval n1
	if f v1 then return v1 else eval n2

evalNodeList :: [Node] -> MyST [Value]
evalNodeList []     = return []
evalNodeList (x:xs) = do
	v <- eval x
	vs <- evalNodeList xs
	return $ v:vs

call :: Node -> Value -> [Value] -> MyST Value
call fnode (Function args body env) params
	| length params /= length args  = fail $ show fnode ++ ": illegal argnum, " ++ show (length params) ++ " for " ++ show (length args)
	| otherwise = do
		st <- get
		put $ st { curenv = Just (extend args params env) }
		res <- eval body
		put st
		return res
	where
		extend args params parent_env = Environment dic parent_env
			where
				dic = foldl (\e (a,p) -> doAssign a p e) emptyDictionary $ zip args params
call fnode (Native argnum f) params
	| length params /= argnum = fail $ show fnode ++ ": illegal argnum, " ++ show (length params) ++ " for " ++ show argnum
	| otherwise = return $ DDouble $ f $ map (\(DDouble v) -> v) params
call fnode v _ = fail $ show fnode ++ " is not function"
  • Haskellの関数の定義や呼び出しの形式は、引数なしの関数が扱えない形になってるんですね。この電卓にrandとかtimeとかを用意しようかと思って愕然とした。
トラックバック - http://haskell.g.hatena.ne.jp/mokehehe/20090805