たなかさんのおにくをたべよう

Haskell界の有名なエンジニアで、「すごいH本」ことすごいHaskellたのしく学ぼうの翻訳もされている田中英行さんのご自宅にて、少人数のハッカソン「たなかにくまつり」が開催されたので参加して来ました。

開催されるまでの経緯とか色々あるのですが、とにかくまぁ、尊敬しているHaskellerさんと直接お話できる機会と思いエントリーしたわけですね。決して他意は無いです。

無いですってば。

意気揚々と参戦したものの、やっぱり皆さんレベルが高い高い。結局、話にまともに付いていけたのはモナドに関する話題くらいでして。
しゃーないので、はしっこのほうでタコ焼きをもちゃもちゃ食べながらコードを書いていた次第です。

せっかくFreeモナドの使い方を覚えたので、Parsecの勉強と合わせて簡単なスタック型プログラミング言語を作ってみようと思っていたのですが、流石に１日だけだと構文木とインタプリタ処理系を作るのが限界でした。
状態を保持するための領域がスタックだけの言語なので、チューリング完全では無いんじゃないかなぁと思います。

とりあえず、大したものでは無いから、なるべく早いうちに完成させてしまうつもりなので、構文とか言語仕様の話はその時に書くとしましょう。
とりあえず今日はコードだけ貼っておくので、テストコードから雰囲気だけ掴んで貰えれば良いかと思われます。
Freeモナドにすると、do構文でほぼそのままの記述ができるのは嬉しいです。

Language/BricksLang/SyntaxTree.hs:

module Language.BricksLang.SyntaxTree where
import Control.Monad.Free

---------------------------------------------------------------------------------------------------
--構文木データ定義

data Bricks a
  = BricksPush Int a
  | BricksPop a
  | BricksPutChar a
  | BricksPutInt a
  | BricksAdd a
  | BricksEq a
  | BricksLabel String a
  | BricksGoto String a
  | BricksThrow String a
  deriving (Show, Eq)

--Freeモナドで扱うためにFunctorにする
instance Functor Bricks where
  fmap f (BricksPush x n) = BricksPush x (f n) 
  fmap f (BricksPop n) = BricksPop (f n) 
  fmap f (BricksPutChar n) = BricksPutChar (f n) 
  fmap f (BricksPutInt n) = BricksPutInt (f n) 
  fmap f (BricksLabel l n) = BricksLabel l (f n)
  fmap f (BricksAdd n) = BricksAdd (f n) 
  fmap f (BricksEq n) = BricksEq (f n) 
  fmap f (BricksGoto l n) = BricksGoto l (f n) 
  fmap f (BricksThrow m n) = BricksThrow m (f n)

---------------------------------------------------------------------------------------------------
--構文を組み立てるFreeモナド関数化

liftF :: Functor f => f r -> Free f r
liftF cmd = Impure (fmap Pure cmd)

bPush :: Int -> Free Bricks ()
bPush x = liftF $ BricksPush x ()

bPop :: Free Bricks ()
bPop = liftF $ BricksPop ()

bPutChar :: Free Bricks ()
bPutChar = liftF $ BricksPutChar ()

bPutInt :: Free Bricks ()
bPutInt = liftF $ BricksPutInt ()

bLabel :: String -> Free Bricks ()
bLabel m = liftF $ BricksLabel m ()

bGoto :: String -> Free Bricks ()
bGoto m = liftF $ BricksGoto m ()

bAdd :: Free Bricks ()
bAdd = liftF $ BricksAdd ()

bEq :: Free Bricks ()
bEq = liftF $ BricksEq ()

bThrow :: String -> Free Bricks ()
bThrow m = liftF $ BricksThrow m ()

Language/BricksLang/Interpreter.hs:

module Language.BricksLang.Interpreter( 
  module Language.BricksLang.SyntaxTree , execBricks , makeLabelTable ) where
import Language.BricksLang.SyntaxTree 
import Control.Monad.Free
import Data.Char
import qualified Data.Map as M

---------------------------------------------------------------------------------------------------

execBricks :: Free Bricks () -> IO ()
execBricks program = runBricks ([], M.fromList (makeLabelTable program)) program

---------------------------------------------------------------------------------------------------
--ラベルテーブル作成
---------------------------------------------------------------------------------------------------

makeLabelTable :: Free Bricks a -> [(String, Free Bricks a)]
makeLabelTable (Pure _) = [] 
makeLabelTable (Impure (BricksLabel a n)) = (a, n) : makeLabelTable n
makeLabelTable (Impure (BricksPush _ n)) = makeLabelTable n
makeLabelTable (Impure (BricksPop n)) = makeLabelTable n
makeLabelTable (Impure (BricksPutChar n)) = makeLabelTable n
makeLabelTable (Impure (BricksPutInt n)) = makeLabelTable n
makeLabelTable (Impure (BricksAdd n)) = makeLabelTable n
makeLabelTable (Impure (BricksEq n)) = makeLabelTable n
makeLabelTable (Impure (BricksThrow _ n)) = makeLabelTable n
makeLabelTable (Impure (BricksGoto _ n)) = makeLabelTable n

---------------------------------------------------------------------------------------------------
--Bricks-langインタプリタ実行
---------------------------------------------------------------------------------------------------

type BricksState a = ([Int], M.Map String (Free Bricks a))

---------------------------------------------------------------------------------------------------

runBricks :: BricksState a -> Free Bricks a ->  IO a

-- Push
runBricks (xs, m) (Impure (BricksPush x n)) = runBricks ((x:xs), m) n

-- Pop
runBricks ([], m) (Impure (BricksPop n)) 
  = error "[Bricks-lang runtime error] `Pop` couldn't run because stack is empty"
runBricks ((_:xs), m) (Impure (BricksPop n)) = runBricks (xs, m) n

--PutChar
runBricks ([], _) (Impure (BricksPutChar n)) 
  = error "[Bricks-lang runtime error] `PutChar` couldn't run because stack is empty"
runBricks st@((x:_), m) (Impure (BricksPutChar n)) = putChar (chr x) >> runBricks st n

--PutInt
runBricks ([], _) (Impure (BricksPutInt n)) 
  = error "[Bricks-lang runtime error] `PutInt` couldn't run becaouse stack is empty"
runBricks st@((x:_), m) (Impure (BricksPutInt n)) = (putStr.show) x >> runBricks st n

--Label ・・・何もしない
runBricks st (Impure (BricksLabel _ n)) = runBricks st n

--Throw
runBricks _ (Impure (BricksThrow m _)) = error $ "[Bricks-lang runtime error] EXCEPTION : " ++ m

--Goto
runBricks st@((0:_), m) (Impure (BricksGoto l _)) = callNext $ M.lookup l m
  where
  callNext Nothing = error $ "[Bricks-lang runtime error] `Goto` couldn't find label `" ++ l ++ "`"
  callNext (Just n) =  runBricks st n
runBricks st (Impure (BricksGoto _ n)) = runBricks st n

--Add
runBricks ((x:y:xs), m) (Impure (BricksAdd n)) = runBricks ((x + y:xs) ,m) n
runBricks _ (Impure (BricksAdd _)) = 
  error $ "[Bricks-kang runtime error] `Add` couldn't run becaouse stack is empty"

--Eq
runBricks (xs@(x:y:_), m) (Impure (BricksEq n)) = runBricks ((eq x y:xs) ,m) n
  where eq x y = if x == y then 0 else 1
runBricks _ (Impure (BricksEq _)) = 
  error $ "[Bricks-kang runtime error] `Add` couldn't run becaouse stack is empty"

-- ...Pure
runBricks _ (Pure x) = return x

テストプログラム:

module Test.Interpreter() where
import Language.BricksLang.Interpreter

main = execBricks $ do
  --Loop開始定形処理
  bPush 3 --Loop回数
  bPush 1
  bPush 1
  bLabel "Loop"
  bPop
  bPop

  --主処理
  bPush 66
  bPush 65
  bPutChar --A
  bPop
  bPutChar --B
  bPop

  --Loop終了定形処理
  bPush (-1)
  bAdd
  bPush 0
  bEq
  bPush (-1)
  bAdd
  bGoto "Loop" --Gotoはスタックの一番上の要素が 0 の時だけ実行される
  
  --Loop開始定形処理
  bPush 3 --Loop回数
  bPush 1
  bPush 1
  bLabel "Loop2"
  bPop
  bPop

  --主処理
  bPush 68
  bPush 67
  bPutChar --C
  bPop
  bPutChar --D
  bPop

  --Loop終了定形処理
  bPush (-1)
  bAdd
  bPush 0
  bEq
  bPush (-1)
  bAdd
  bGoto "Loop2"

実行結果：

ABABABCDCDCD

とゆーわけで、楽しい時間ありがとうございましたーm(__)m