TypeScript の型レベルプログラミングで Brainf**k

こんにちは、モバファクエンジニアの id:knj-mf です。

今回は TypeScript の型レベルプログラミングでちょっと面白いものを作ったので紹介したいと思います。

何を作ったの？

TypeScript の型レベルプログラミングは、予想に反して様々なものが実装できてしまうことで有名だったりします。

type-challenges のように、「これは普通のプログラミングで実装するものでは？」と思ってしまうようなものまで実装できてしまいます。そこで、作ってみたものが下記になります。

早速、動作を紹介します。このような Brainf**k プログラムの文字列型が…

このように、型計算上で解釈されてしまう！というものです。

ある程度の形になるものはできたので、この記事では、型レベルプログラミングと書き味の近い (個人差があります) Haskell 実装と照らしながら、どのように考えてこの「型」を実装していったのかを紹介します。 cwd-k2/bf-in-type のリポジトリに実装があるので、気になる方は手元で動作や実装を見てみてください。

Brainf**k？

たった 8 つの命令からなる難読プログラミング言語です。言語の仕様としてかなり単純明快ではありますが、チューリング完全として知られています。(ちょっと企業の公式ブログには載せづらい表記を含むので、今回は ** という風に伏せさせていただきます…)

要素として、次の 4 つのものを持ちます。

要素	内容
プログラムテープ	実行するプログラム列
メモリテープ	値を記録するセルの列
プログラムポインタ	現在参照しているプログラム命令列上の位置
メモリポインタ	現在参照しているメモリテープの位置

8 つの命令は次のような単純なものです。

命令	内容
>	メモリポインタをインクリメント（次のセルへ）
<	メモリポインタをデクリメント（前のセルへ）
+	現在セルの値をインクリメント
-	現在セルの値をデクリメント
.	現在セルの値を ASCII 文字として出力
,	1 バイト読み込み、現在セルへ格納
[	現在セルが 0 なら、対応する ] の直後へジャンプ
]	現在セルが 0 でなければ、対応する [ の直後へジャンプ

ざっくり、プログラムテープ上に記載された 8 つの命令の列を順次実行しながらメモリテープの値を書き換えつつ、適宜 I/O していく形のプログラミング言語になります。

実際の Brainf**k プログラムそのものはまったく実用性がないのですが、この簡単な命令セットからなる言語処理系の実装には教育的価値があります。結構書いてみたことがあるというエンジニアの方も多いのではないでしょうか。

TypeScript の型レベルプログラミング

ところで、TypeScript には (TypeScript に限りませんが) 型レベルプログラミングがあります。本当に単純な例だと、下記のようなものです。

type ExtendsObject<T> = T extends object ? true : false

これが何をしているのかというと、型チェックの際に実施される型計算を実装しているということです。上記のような条件分岐などのロジックが型レベルで解決されてしまうということですね。

この型レベルプログラミングなのですが、表現力はさておき、チューリング完全な系になってしまっているとのもっぱらの評判です。

型から型を新たに計算できてしまうということは… 楽しいプログラミングの時間の始まりですね。

実装方針

長くなってしまうので、以降では Brainf**k を BF と記載することにします。

BF 処理系を型レベルに落とし込むにあたって、次の 4 つの要素に分けて考えます。

• テープ構造体 (Tape) — メモリ・プログラムを共通して表現するデータ構造
  • 現在位置を持ちつつ、前後に移動する能力を持つ
• 評価器 (Runner) — メモリテープとプログラムテープを束ねた実行状態
  • メモリを変化させつつプログラムポインタを移動するため、同時に扱う
• アクション (Action) — 1 ステップ実行の結果として外界に要求する効果 (なにもしない / 入力 / 出力 / 終了)
• 評価ループ (Exec) — アクションを解釈して評価器を回し、入力を消費しつつ出力を蓄積するメインループ

型レベルプログラミングでは副作用を素直に書けないため、入出力を「アクション型」としてデータに落としておき、外側のループでそれを解釈する形にしたのがポイントです。以降、この順で各要素の実装を見ていきます。

また、適宜参考実装として Haskell の実装も合わせて示しています。

TypeScript 実装は v5.4 以降で動作確認しています。

実装上の制約

制約として、実装レベルに効いてくるものもあります。数値での演算や数値⇔文字の変換が基本的にできない、というものです。不可能ではないですが、タプル (型レベル配列) の length を取るような実装になりがちなのでまわりくどくなります。

今回は ASCII 範囲でインクリメント・デクリメントを考えるだけなので、気合いで誤魔化すことができます。NumToCharMap[65] のように参照すると 'A' という型に解決される、というマップを定義しました。

数値文字変換、インクリメント・デクリメントマップの実装

export type NumToCharMap = [
  '\x00', '\x01', '\x02', '\x03', '\x04', '\x05', '\x06', '\x07', '\x08', '\x09', '\x0A', '\x0B', '\x0C', '\x0D', '\x0E', '\x0F',
  '\x10', '\x11', '\x12', '\x13', '\x14', '\x15', '\x16', '\x17', '\x18', '\x19', '\x1A', '\x1B', '\x1C', '\x1D', '\x1E', '\x1F',
  '\x20', '\x21', '\x22', '\x23', '\x24', '\x25', '\x26', '\x27', '\x28', '\x29', '\x2A', '\x2B', '\x2C', '\x2D', '\x2E', '\x2F',
  '\x30', '\x31', '\x32', '\x33', '\x34', '\x35', '\x36', '\x37', '\x38', '\x39', '\x3A', '\x3B', '\x3C', '\x3D', '\x3E', '\x3F',
  '\x40', '\x41', '\x42', '\x43', '\x44', '\x45', '\x46', '\x47', '\x48', '\x49', '\x4A', '\x4B', '\x4C', '\x4D', '\x4E', '\x4F',
  '\x50', '\x51', '\x52', '\x53', '\x54', '\x55', '\x56', '\x57', '\x58', '\x59', '\x5A', '\x5B', '\x5C', '\x5D', '\x5E', '\x5F',
  '\x60', '\x61', '\x62', '\x63', '\x64', '\x65', '\x66', '\x67', '\x68', '\x69', '\x6A', '\x6B', '\x6C', '\x6D', '\x6E', '\x6F',
  '\x70', '\x71', '\x72', '\x73', '\x74', '\x75', '\x76', '\x77', '\x78', '\x79', '\x7A', '\x7B', '\x7C', '\x7D', '\x7E', '\x7F',
] & {
  [i: number]: '\x00'
};

export type CharToNumMap = {
  '\x00': 0x00, '\x01': 0x01, '\x02': 0x02, '\x03': 0x03, '\x04': 0x04, '\x05': 0x05, '\x06': 0x06, '\x07': 0x07, '\x08': 0x08, '\x09': 0x09, '\x0A': 0x0A, '\x0B': 0x0B, '\x0C': 0x0C, '\x0D': 0x0D, '\x0E': 0x0E, '\x0F': 0x0F,
  '\x10': 0x10, '\x11': 0x11, '\x12': 0x12, '\x13': 0x13, '\x14': 0x14, '\x15': 0x15, '\x16': 0x16, '\x17': 0x17, '\x18': 0x18, '\x19': 0x19, '\x1A': 0x1A, '\x1B': 0x1B, '\x1C': 0x1C, '\x1D': 0x1D, '\x1E': 0x1E, '\x1F': 0x1F,
  '\x20': 0x20, '\x21': 0x21, '\x22': 0x22, '\x23': 0x23, '\x24': 0x24, '\x25': 0x25, '\x26': 0x26, '\x27': 0x27, '\x28': 0x28, '\x29': 0x29, '\x2A': 0x2A, '\x2B': 0x2B, '\x2C': 0x2C, '\x2D': 0x2D, '\x2E': 0x2E, '\x2F': 0x2F,
  '\x30': 0x30, '\x31': 0x31, '\x32': 0x32, '\x33': 0x33, '\x34': 0x34, '\x35': 0x35, '\x36': 0x36, '\x37': 0x37, '\x38': 0x38, '\x39': 0x39, '\x3A': 0x3A, '\x3B': 0x3B, '\x3C': 0x3C, '\x3D': 0x3D, '\x3E': 0x3E, '\x3F': 0x3F,
  '\x40': 0x40, '\x41': 0x41, '\x42': 0x42, '\x43': 0x43, '\x44': 0x44, '\x45': 0x45, '\x46': 0x46, '\x47': 0x47, '\x48': 0x48, '\x49': 0x49, '\x4A': 0x4A, '\x4B': 0x4B, '\x4C': 0x4C, '\x4D': 0x4D, '\x4E': 0x4E, '\x4F': 0x4F,
  '\x50': 0x50, '\x51': 0x51, '\x52': 0x52, '\x53': 0x53, '\x54': 0x54, '\x55': 0x55, '\x56': 0x56, '\x57': 0x57, '\x58': 0x58, '\x59': 0x59, '\x5A': 0x5A, '\x5B': 0x5B, '\x5C': 0x5C, '\x5D': 0x5D, '\x5E': 0x5E, '\x5F': 0x5F,
  '\x60': 0x60, '\x61': 0x61, '\x62': 0x62, '\x63': 0x63, '\x64': 0x64, '\x65': 0x65, '\x66': 0x66, '\x67': 0x67, '\x68': 0x68, '\x69': 0x69, '\x6A': 0x6A, '\x6B': 0x6B, '\x6C': 0x6C, '\x6D': 0x6D, '\x6E': 0x6E, '\x6F': 0x6F,
  '\x70': 0x70, '\x71': 0x71, '\x72': 0x72, '\x73': 0x73, '\x74': 0x74, '\x75': 0x75, '\x76': 0x76, '\x77': 0x77, '\x78': 0x78, '\x79': 0x79, '\x7A': 0x7A, '\x7B': 0x7B, '\x7C': 0x7C, '\x7D': 0x7D, '\x7E': 0x7E, '\x7F': 0x7F,
} & {
  [k: string]: 0x00;
};

export type DecrementMap = [
  0x7F,
  0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0A, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
  0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x1B, 0x1C, 0x1D, 0x1E, 0x1F,
  0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x2B, 0x2C, 0x2D, 0x2E, 0x2F,
  0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3A, 0x3B, 0x3C, 0x3D, 0x3E, 0x3F,
  0x40, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F,
  0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0x5B, 0x5C, 0x5D, 0x5E, 0x5F,
  0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F,
  0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x7B, 0x7C, 0x7D, 0x7E,
] & {
  [i: number]: 0x7F;
};

export type IncrementMap = [
        0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, 0x08, 0x09, 0x0A, 0x0B, 0x0C, 0x0D, 0x0E, 0x0F,
  0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x1B, 0x1C, 0x1D, 0x1E, 0x1F,
  0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x2B, 0x2C, 0x2D, 0x2E, 0x2F,
  0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3A, 0x3B, 0x3C, 0x3D, 0x3E, 0x3F,
  0x40, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4A, 0x4B, 0x4C, 0x4D, 0x4E, 0x4F,
  0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0x5B, 0x5C, 0x5D, 0x5E, 0x5F,
  0x60, 0x61, 0x62, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x6B, 0x6C, 0x6D, 0x6E, 0x6F,
  0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x7B, 0x7C, 0x7D, 0x7E, 0x7F,
  0x00,
] & {
  [i: number]: 0x00;
};

テープ構造体

BF では、メモリを用意してポインタ操作・ポインタを介した操作が前提になっています。 もちろん型レベルプログラミングで副作用は記述しにくいため、ポインタ前提となっている部分を再考し、同じ表現力の別の形に置き換える必要があります。

メモリ、プログラムを同じテープ構造で捉えます。今着目している値、その左右に列が続いている様子を考えたのが下記のような構造になります。

テープ構造体の実装

このような構造体は、Haskell での data 宣言と同じような形で、TypeScript の型ではオブジェクト型による宣言ができます。

data Tape a
  = Tape { prevs :: [a]
         , curr  :: a
         , nexts :: [a]
         }

extends unknown[] によって単なる配列型ではなく、各要素が独立した型レベル配列としてのタプルを利用できます。

export type Tape<Hs extends unknown[], C, Ts extends unknown[]> = {
  h: Hs
  c: C
  t: Ts
}

ここでいくつかの基本的な操作も定義してしまいましょう。

• 現在の値に対する操作
  • インクリメント・デクリメント
  • 読み出し、書き込み
• テープ上の移動
  • 着目するヘッドを左右に移動する操作
  • 対応する [, ] へのジャンプは繰り返しによって実現する

基本操作の実装

Tape a から新しい Tape a を作る (Tape a -> Tape a) という形の実装となります。

-- | 次の要素に移動
next :: Tape a -> Tape a
next (Tape prevs curr (n:nexts)) = Tape (curr:prevs) n nexts

-- | 前の要素に移動
prev :: Tape a -> Tape a
prev (Tape (p:prevs) curr nexts) = Tape prevs p (curr:nexts)

-- | 現在の要素をインクリメント
incr :: Enum a => Tape a -> Tape a
incr (Tape prevs curr nexts) = Tape prevs (succ curr) nexts

-- | 現在の要素をデクリメント
decr :: Enum a => Tape a -> Tape a
decr (Tape prevs curr nexts) = Tape prevs (pred curr) nexts

-- | 現在の要素を取得
get :: Tape a -> a
get (Tape _ curr _) = curr

-- | 現在の要素を設定
put :: a -> Tape a -> Tape a
put a (Tape prevs _ nexts) = Tape prevs a nexts

TypeScript の型でも同様に、Tape を受け取って新しい Tape を作成するという方針で実装できます。 [infer H, ...infer Hs] のパターンマッチングにより、型レベル配列の要素 (head, rest) を扱うことができてしまいます。

export type Prev<M> =
  M extends Tape<[infer H, ...infer Hs], infer C, infer Ts>
    ? Tape<Hs, H, [C, ...Ts]>
    : never

export type Next<M> =
  M extends Tape<infer Hs, infer C, [infer T, ...infer Ts]>
    ? Tape<[C, ...Hs], T, Ts>
    : never

export type Incr<M> =
  M extends Tape<infer Hs, infer C extends number, infer Ts>
    ? Tape<Hs, IncrementMap[C], Ts>
    : never

export type Decr<M> =
  M extends Tape<infer Hs, infer C extends number, infer Ts>
    ? Tape<Hs, DecrementMap[C], Ts>
    : never

export type PutC<M, C> =
  M extends Tape<infer Hs, unknown, infer Ts> ? Tape<Hs, C, Ts> : never

プログラム実行

基本的な構造、操作は定義してしまったので、次はインタプリタとして重要な実行について考えます。

評価器としての実行系内部 (メモリ・プログラムポインタ) と外界とのやりとりを含む効果の管理の部分を、次のような形で切り分けます。

型レベルプログラミングでは入出力をそのまま扱うことはできないので、入力待ちや出力があるということは特別な状態として表現することにします。

評価器の内部状態

こちらは至ってシンプルです。

• 状態はメモリ、プログラムのテープ (現在位置を保持する) から成る
• これを評価に通すことによって、次の実行に関する状態が出てくる

data Machine = Machine
  { memory  :: DT.Tape Int
  , program :: DT.Tape Char
  }

type Runner<M, P> = {
  mem: M
  prg: P
}

外部とのやりとりを含むアクション

今のメモリ・プログラムを含む、先程の構造を評価して得られるアクションです。

-- | 何もしない、入力要求、出力要求、終了の 4 つのアクションを持つ
data WithAction a
  = ActionN { hold :: a }             -- ^ 外部には何もしない
  | ActionI { hold :: a }             -- ^ 入力要求
  | ActionO { hold :: a, out :: Int } -- ^ 出力要求
  | ActionE                           -- ^ 終了

これを型レベルプログラミングで再現すると、ADT よりは個別の型として定義してあげて、後で extends などの条件分岐してあげる方が素直になります。

type ActionN<R> = { action: "N"; runner: R }
type ActionI<R> = { action: "I"; runner: R }
type ActionO<R, O> = { action: "O"; runner: R; output: O }
type ActionE = { action: "E" }

8 つの命令に対する操作の整理

評価器の状態とアクションを型として定義できたので、次はプログラムの示す命令を処理していく実装も考えていきます。

これは最初に確認した BF の 8 つの命令に対して、次の評価器の状態と計算の効果を含む全体を返す形で定義していけば良いです。

インクリメント

デクリメント

次を参照 (ポインタインクリメント)

前を参照 (ポインタデクリメント)

while (ジャンプ)

while end (ジャンプバック)

getchar

putchar

命令→次の状態・アクション

さて、図で整理できたので、実装にそのまま落としていきます。

現在の命令ポインタが指す命令に応じて、次の Action と状態を返します。

-- | 次のステップを実行し、状態とアクションを返す
step :: Machine -> WithAction Machine
step machine = case pc of
  '+' -> ActionN $ machine { memory = DT.incr (memory machine), program = DT.next (program machine) }
  '-' -> ActionN $ machine { memory = DT.decr (memory machine), program = DT.next (program machine) }
  '>' -> ActionN $ machine { memory = DT.next (memory machine), program = DT.next (program machine) }
  '<' -> ActionN $ machine { memory = DT.prev (memory machine), program = DT.next (program machine) }
  '[' -> ActionN $ machine { program = if mc == 0 then skip (program machine) else DT.next (program machine) }
  ']' -> ActionN $ machine { program = if mc /= 0 then back (program machine) else DT.next (program machine) }
  ',' -> ActionI { hold = machine { program = DT.next (program machine) } }
  '.' -> ActionO { hold = machine { program = DT.next (program machine) }, out = DT.get (memory machine) }
  _ -> ActionE
  where
    (pc, mc) = (,) <$> DT.get . program <*> DT.get . memory $ machine

TypeScript で書いても、ほとんど同じ対応があります。

type Step<R> =
  R extends Runner<
    infer M extends TapeMm,
    infer P extends TapePg
  >
    ? P['c'] extends '+' ? ActionN<Runner<Incr<M>, Next<P>>>
    : P['c'] extends '-' ? ActionN<Runner<Decr<M>, Next<P>>>
    : P['c'] extends '>' ? ActionN<Runner<Next<M>, Next<P>>>
    : P['c'] extends '<' ? ActionN<Runner<Prev<M>, Next<P>>>
    : P['c'] extends '[' ? ActionN<Runner<M, M['c'] extends 0 ? Skip<P> : Next<P>>>
    : P['c'] extends ']' ? ActionN<Runner<M, M['c'] extends 0 ? Next<P> : Back<P>>>
    : P['c'] extends ',' ? ActionI<Runner<M, Next<P>>>
    : P['c'] extends '.' ? ActionO<Runner<M, Next<P>>, M['c']>
    : ActionE
  : never;

状態・アクション→継続

次は状態、アクションを受けて、次のステップに継続していくループを実装していきます。

上記の step を実行し、その Action に応じた操作を実行していきます。

-- | 入力を消費・出力を収集しながら step を繰り返す
loop :: (Machine -> WithAction Machine) -> (String, Machine) -> String
loop step (input, machine) = go (step machine) where
  -- アクションに対応した動作を実行し、再帰に進む
  go (ActionN machine') = loop step (input, machine')                  -- そのまま次へ
  go (ActionI machine') = loop step (iTail, machine'') where           -- 入力を消費してメモリに書き込み、次に進む
    (iHead : iTail) = input
    machine'' = machine' { memory = DT.put (fromEnum iHead) (memory machine') }
  go (ActionO machine' out) = toEnum out : loop step (input, machine') -- 出力を収集し、次に進む
  go ActionE = []                                                      -- 終端

TypeScript の型の方では、今回は文字列の累積を保持する形で実装しています。ちょっと命名が異なってしまっていますが、やっていることは同じです。

type Exec<
  R,
  I extends string,
  O extends string = ''
> =
  Step<R> extends infer WithAction
    ? WithAction extends ActionN<infer Q>
      ? Exec<Q, I, O>
    : WithAction extends ActionI<infer Q>
      ? I extends `${infer F}${infer S}`
        ? Exec<Read<Q, CharToNumMap[F]>, S, O>
        : Exec<Read<Q, 0>, I, O>
    : WithAction extends ActionO<infer Q, infer N extends number>
      ? Exec<Q, I, `${O}${NumToCharMap[N]}`>
    : WithAction extends ActionE
      ? O
    : never
  : never;

まとめ

TypeScript で Brainf**k 処理系の型レベルプログラムの実装について見ていきました。

補足として、TypeScript の型レベルプログラミング実行系には次のような制約があります。

• 型の再帰評価回数、つまり実行できるステップ数が制限されている
• Tape 構造体の保持する要素列の長さに制限がある
• (どちらも大体 1,000 程度のイメージ)

一方、このような制限がある中でも、冒頭に示した例のように簡単な Hello World の例までは実装できてしまいます。

みなさんもぜひ自分の型レベルプログラミングに挑戦してみてください。

私が今回示した実装も最善ではないと思います。「もっと良いものを書いてみよう」など、楽しんでみてください。

付録

Haskell のコード全文を掲載しておきます。

cwd-k2/bf-in-type のリポジトリと比較する、または手元でテスト実行するなどしてください。

• ディレクトリ構成

.
├── Data
│   └── Tape.hs
├── Interpreter.hs
└── Main.hs

• Data/Tape.hs

module Data.Tape (
  Tape(..),
  zeros,
  fromList,
  next,
  prev,
  incr,
  decr,
  get,
  put,
) where

-- | テープ様構造体
-- * 前後に無限に要素があり、現在要素 (針の先にあるもの) を中心に配置している
--
-- > <-prev- ... 4 5 6 <<7>> 8 9 10 ... -next->
data Tape a
  = Tape { prevs :: [a]
         , curr :: a
         , nexts :: [a]
         }
  deriving Show

-- | ゼロ初期化された無限長のテープ
zeros :: Enum a => Tape a
zeros = Tape (repeat $ toEnum 0) (toEnum 0) (repeat $ toEnum 0)

-- | リストからテープを作成
fromList :: [a] -> Tape a
fromList (x:xs) = Tape [] x xs
fromList [] = undefined -- 今回は特に考えずに未定義とする

-- | 次の要素に移動
next :: Tape a -> Tape a
next (Tape prevs curr (n:nexts)) = Tape (curr:prevs) n nexts

-- | 前の要素に移動
prev :: Tape a -> Tape a
prev (Tape (p:prevs) curr nexts) = Tape prevs p (curr:nexts)

-- | 現在の要素をインクリメント
incr :: Enum a => Tape a -> Tape a
incr (Tape prevs curr nexts) = Tape prevs (succ curr) nexts

-- | 現在の要素をデクリメント
decr :: Enum a => Tape a -> Tape a
decr (Tape prevs curr nexts) = Tape prevs (pred curr) nexts

-- | 現在の要素を取得
get :: Tape a -> a
get (Tape _ curr _) = curr

-- | 現在の要素を設定
put :: a -> Tape a -> Tape a
put a (Tape prevs _ nexts) = Tape prevs a nexts

• Interpreter.hs

module Interpreter
  ( bf
  ) where

import qualified Data.Tape as DT
import Data.List (unfoldr)

-- | メモリとプログラムを持つ
data Machine = Machine
  { memory  :: DT.Tape Int
  , program :: DT.Tape Char
  }
  deriving Show

-- | 何もしない、入力要求、出力要求、終了の 4 つのアクションを持つ
data WithAction a
  = ActionN { hold :: a }             -- ^ 外部には何もしない
  | ActionI { hold :: a }             -- ^ 入力要求
  | ActionO { hold :: a, out :: Int } -- ^ 出力要求
  | ActionE                           -- ^ 終了
  deriving Show

-- | 対応する @']'@ までプログラムをスキップする
skip :: DT.Tape Char -> DT.Tape Char
skip = skipInner 0 where
  skipInner n program =
    let program' = DT.next program
     in case DT.get program' of
      '[' -> skipInner (n + 1) program'
      ']' -> if n == 0
                then program'
                else skipInner (n - 1) program'
      _   -> skipInner n program'

-- | 対応する @'['@ までプログラムを戻す
back :: DT.Tape Char -> DT.Tape Char
back = backInner 0 where
  backInner n program =
    let program' = DT.prev program
     in case DT.get program' of
      ']' -> backInner (n + 1) program'
      '[' -> if n == 0
                then program'
                else backInner (n - 1) program'
      _   -> backInner n program'

-- | 次のステップを実行し、状態とアクションを返す
step :: Machine -> WithAction Machine
step machine = case pc of
  '+' -> ActionN $ machine { memory = DT.incr (memory machine), program = DT.next (program machine) }
  '-' -> ActionN $ machine { memory = DT.decr (memory machine), program = DT.next (program machine) }
  '>' -> ActionN $ machine { memory = DT.next (memory machine), program = DT.next (program machine) }
  '<' -> ActionN $ machine { memory = DT.prev (memory machine), program = DT.next (program machine) }
  '[' -> ActionN $ machine { program = if mc == 0 then skip (program machine) else DT.next (program machine) }
  ']' -> ActionN $ machine { program = if mc /= 0 then back (program machine) else DT.next (program machine) }
  ',' -> ActionI { hold = machine { program = DT.next (program machine) } }
  '.' -> ActionO { hold = machine { program = DT.next (program machine) }, out = DT.get (memory machine) }
  _ -> ActionE
  where
    (pc, mc) = (,) <$> DT.get . program <*> DT.get . memory $ machine

-- | 入力を消費・出力を収集しながら step を繰り返す
loop :: (Machine -> WithAction Machine) -> (String, Machine) -> String
loop step (input, machine) = go (step machine) where
  -- アクションに対応した動作を実行し、再帰に進む
  go (ActionN machine') = loop step (input, machine')                  -- そのまま次へ
  go (ActionI machine') = loop step (iTail, machine'') where           -- 入力を消費してメモリに書き込み、次に進む
    (iHead : iTail) = input
    machine'' = machine' { memory = DT.put (fromEnum iHead) (memory machine') }
  go (ActionO machine' out) = toEnum out : loop step (input, machine') -- 出力を収集し、次に進む
  go ActionE = []                                                      -- 終端

-- | Bf プログラムから、入力を受け取って出力を返す関数を作る
bf :: String -> [Char] -> String
bf program input = loop step (input', machine) where
  input' = input ++ repeat '\0'
  machine = Machine
    { memory  = DT.zeros
    , program = DT.next $ DT.fromList ("#" ++ program ++ "#")
    }

• Main.hs

module Main where

import           Interpreter

-- | ハローワールドする Bf プログラム
helloWorld :: String
helloWorld = "++++++++++[>+++++++>++++++++++>+++++++++++>+++>+++++++++>+<<<<<<-]>++.>+.>--..+++.>++.>---.<<.+++.------.<-.>>+.>>."

-- | エコーする Bf プログラム
echo :: String
echo = "+[,.]"

main :: IO ()
main = do
  let getOutputBf = bf helloWorld
  putStr $ getOutputBf "こんにちは\n"