F# で STUDENT

PAIP [1] の第7章に出てくる STUDENT プログラム [2]（の方程式を解く部分のみ）を F# で書いてみた。どの辺が OCaml でなく F# かというと active pattern を使っている部分と num 型のリテラルの部分。

#nowarn "57";;

open Num;;
type op = Add | Sub | Mul | Div;;
type expr = Val of num | Var of string | App of op * expr * expr;;
type equation = expr * expr;;
type binding = string * num;;

let rec eval bs = function
| Val n -> n
| Var s -> List.assoc s bs
| App (Add, l, r) -> add_num  (eval bs l) (eval bs r)
| App (Sub, l, r) -> sub_num  (eval bs l) (eval bs r)
| App (Mul, l, r) -> mult_num (eval bs l) (eval bs r)
| App (Div, l, r) -> div_num  (eval bs l) (eval bs r)
;;

let rec show_expr = function
| Val n -> string_of_num n
| Var s -> s
| App (Add, l, r) -> "(" ^ show_expr l ^ " + " ^ show_expr r ^ ")"
| App (Sub, l, r) -> "(" ^ show_expr l ^ " - " ^ show_expr r ^ ")"
| App (Mul, l, r) -> "(" ^ show_expr l ^ " * " ^ show_expr r ^ ")"
| App (Div, l, r) -> "(" ^ show_expr l ^ " / " ^ show_expr r ^ ")"
;;

let show_equation (lhs, rhs) = show_expr lhs ^ " = " ^ show_expr rhs;;

let inverse_op = function Add -> Sub | Sub -> Add | Mul -> Div | Div -> Mul;;

let rec no_unknown bs = function
| Val _ -> true
| Var s when List.mem_assoc s bs -> true
| Var _ -> false
| App (_, l, r) -> (no_unknown bs l) && (no_unknown bs r)
;;

let rec one_unknown bs = function
| Val _ -> None
| Var s when List.mem_assoc s bs -> None
| Var s -> Some s
| App (_, l, r) when no_unknown bs l -> one_unknown bs r
| App (_, l, r) when no_unknown bs r -> one_unknown bs l
| App _ -> None
;;

let either_or x y = match (x, y) with
| None, Some x -> Some x
| Some x, None -> Some x
| _ -> None
;;

let rec ( |One_unknown|_| ) bs = function
| [] -> None
| ((lhs, rhs) as equation)::xs -> match (either_or (one_unknown bs lhs) (one_unknown bs rhs)) with
  | Some x -> Some (x, equation)
  | None -> ( |One_unknown|_| ) bs xs
;;

let rec in_expr x = function
| Val _ -> false
| Var y when x = y -> true
| Var y -> false
| App (_, l, r) -> (in_expr x l) || (in_expr x r)
;;

let rec isolate x = function
| (Var y, rhs) as expr when x = y -> expr
| (lhs, rhs) when in_expr x rhs -> isolate x (rhs, lhs)
| App (op, l, r), rhs when in_expr x l -> isolate x (l, App (inverse_op op, rhs, r))
| App (Add, l, r), rhs when in_expr x r -> isolate x (r, App (Sub, rhs, l))
| App (Mul, l, r), rhs when in_expr x r -> isolate x (r, App (Div, rhs, l))
| App (Sub, l, r), rhs when in_expr x r -> isolate x (r, App (Sub, l, rhs))
| App (Div, l, r), rhs when in_expr x r -> isolate x (r, App (Div, l, rhs))
;;

let solve_arith bs (Var s, rhs) = (s, (eval bs rhs));;

(* remove e xs removes the first occurrence of e from the list xs *)
let rec remove e = function
| [] -> []
| x::xs when x = e -> xs
| x::xs -> x::(remove e xs)
;;

let rec solve bs = function
| (One_unknown bs (variable, equation)) as equations ->
  let answer = solve_arith bs (isolate variable equation) in
  solve (answer::bs) (remove equation equations)
| _ -> bs
;;

let show_binding (s, n) = s ^ " = " ^ (string_of_num n);;

let solve_equations equations =
  print_endline "The equations to be solved are:";
  List.iter (fun x -> print_string (show_equation x); print_newline ()) equations;
  print_endline "The solution is:";
  List.iter (fun x -> print_string (show_binding x); print_newline ()) (solve [] equations)
;;

let e1 = (App (Add,Val 3N,Val 4N),
         App (Mul,App (Sub,Val 5N,App (Add,Val 2N,Var "x")),Val 7N));;
let e2  = (App (Add,App (Mul,Val 3N,Var "x"),Var "y"), Val 12N);;

solve_equations [e1; e2];;

実行結果:

The equations to be solved are:
(3 + 4) = ((5 - (2 + x)) * 7)
((3 * x) + y) = 12
The solution is:
y = 6
x = 2

解説すると、このプログラムは等式群が与えられると

1. 未知の変数が1つしか現れない等式を探し出す
2. その等式を解いて変数を既知にする

を繰り返して最後に既知のリストを返すもので、等式を解くには

1. 左辺値が当該変数だけになるように式を変形する
2. 右辺値を評価する

というのをやる。日本語で書くと単純だけど…

PAIP の Common Lisp 版では変数が既知になった時点で式中の変数を実際の値に置き換えているのだけど、この F# 版では既知の情報を環境として式を評価するように eval 関数を書いた。
Lisp 版では eval が Lisp の eval そのものなので置き換えたほうが楽なのだが F# では特にそういうボーナスはなくて、むしろ式の置き換えと既知情報の更新を両方やるのが redundant だと思ったため。

実はこれは最初 Haskell の練習として書いていたのだけど solve 関数の

「等式のリスト equations が与えられたときに
- one_unknown な等式があるかどうかを判定して
- あればその等式 equation と未知変数名 variable を得て
- variable と equation を使って等式を解き (solve_arith, isolate)
- なおかつ equations から equation を除去する」

という部分が私の Haskell 力ではどうしてもごちゃごちゃな感じにしかならなかったので諦めた。そして active pattern を使うと構文上すっきりさせられることに気づいて F# で書きなおした。

[1] http://norvig.com/paip.html
[2] http://norvig.com/paip/student.lisp

分数を小数に展開と桁あふれと OCaml Sucks

無い知恵を絞って「どう書く？org」の「分数を小数に展開」という問題 [1] にOCaml で投稿してみた [2]。

投稿した後で別の方が「2147483645 / 2147483647 で～」と書いていたので、そういえば問題文の境界値 2^31-1 は OCaml の int では満たせないんだったと気がついたのだけど、じゃあ 2^30-1 の 1073741823 までならできるんだっけと思ってやってみると、

# pretty_fmt (decimal_of_frac 1073741823 1073741823);;
- : string = "1."
# pretty_fmt (decimal_of_frac 1073741823 1073741822);;
- : string =
"1.00000000000000000000000000000-1{0000000000000000000000000000-1}"
# pretty_fmt (decimal_of_frac 1073741822 1073741823);;
- : string =
"0.0000000000000000000000000000{-100000000000000000000000000000}"

あれ…

バグかなあと悩むことしばしの後、どうやら剰余を10倍しているところで桁あふれがおきているのだと気づきました。これはもっと複雑なことをしているときに起こったらかなりはまるだろうなあ。

というわけで OCaml Language Sucks [3] の人が "The biggest trouble is that integer overflow is not detected even at run run time" （原文ママ）と言っているのはこういうことかというのを身をもって理解したのでした。

他の言語の投稿でも普通に int を使っているものは問題文の境界値内で桁あふれが起こるのかな。気にしなくていいのは Python と Common Lisp くらい？

[1] http://ja.doukaku.org/9/
[2] http://ja.doukaku.org/comment/198/
[3] http://www.podval.org/~sds/ocaml-sucks.html

OCaml で書く Tcl インタプリタ 3

Haskell で 250 行で書かれた Tcl インタプリタ [1] というのがあった（行数の数えかたはあやしいが）ので思い出して自作 OCaml 製 Tcl インタプリタ [2] をまたいじってみた。今回は proc, global, upvar に対応してできることの幅がだいぶ広がった。結果として230行に。

open ExtList
open ExtString
module StringMap = Map.Make(String)
exception Unknown_command of string
exception Wrong_number_of_args

let string_of_char = String.make 1

module TclInterp = struct
  type frame_entry = Value of string | Global | Upvar of (string * int)
  type frame = frame_entry StringMap.t

  type interp = {
    result : string;
    g : string StringMap.t;
    frames : frame list;
    procs : (string * proc) list;
  }
  and proc = interp -> string list -> interp

  let initial_interp = {
    result = "";
    g = StringMap.empty;
    frames = [];
    procs = [];
  }

  let uplevel = List.drop
  let global name interp = StringMap.find name interp.g
  let local name frame = StringMap.find name frame

  let rec var_lookup name interp =
    match interp.frames with
      | [] -> global name interp
      | frame::_ as frames ->
        match (local name frame) with
          | Value v -> v
          | Global -> global name interp
          | Upvar (name, level) ->
            var_lookup name {interp with frames = uplevel level frames}

  let set_global name value interp =
    {interp with g = StringMap.add name value interp.g}
  let set_local name value frame = StringMap.add name (Value value) frame

  let rec var_update name value interp =
    match interp.frames with
      | [] -> set_global name value interp
      | frame::xs as frames ->
        if StringMap.mem name frame then
          match (local name frame) with
            | Value _ ->
              {interp with frames = (set_local name value frame)::xs}
            | Global -> set_global name value interp
            | Upvar (name, level) ->
              let intermediate= List.take level frames in
              let upframe = uplevel level frames in
              let interp' =
                var_update name value {interp with frames = upframe} in
              {interp' with frames = intermediate @ interp'.frames}
        else
          {interp with frames = (set_local name value frame)::xs}
end

module TclParserState = struct
  type state = {
      openBraces : int;
      argv : string list;
      buf : string;
      nest : bool;
  }
  let initial_state = {openBraces = 0; argv = []; buf=""; nest = false;}
  let argv_of_state state =
      let argv =
        if state.buf = "" then state.argv else state.buf::state.argv in
      List.rev argv
  let add_arg state =
      {state with argv = state.buf::state.argv; buf = ""}
  let ($^) state c =
      {state with buf = state.buf ^ string_of_char c}
  let ($^^) state s =
      {state with buf = state.buf ^ s}
  let flush state =
      {state with argv = []; buf = ""}
  let incrbrace state =
      {state with openBraces = state.openBraces + 1}
  let decrbrace state =
      {state with openBraces = state.openBraces - 1}
end

open TclInterp
open TclParserState

let invoke interp = function
  | name::args ->
    if List.mem_assoc name interp.procs then
      let proc = List.assoc name interp.procs in
      proc interp args
    else
      raise (Unknown_command name)
  | _ -> raise (Unknown_command "")

let backslash = parser
  | [< ''\n' >] -> ' '
  | [< ''n'  >] -> '\n'
  | [< ''t'  >] -> '\t'
  | [< 'c    >] -> c
  | [<       >] -> '\\'

let rec varsub interp name = parser
  | [< ''A'..'Z' | 'a'..'z' | '_' | '0'..'9' as c; strm>]
          -> varsub interp (name ^ string_of_char c) strm
  | [< >] -> if name = "" then "$" else var_lookup name interp

let rec eval interp state = parser
  | [< '' '|'\t'|'\r'|'\n'|';'; strm >] -> eval interp state strm
  | [< ''#'; strm >] -> comment interp state strm
  | [< strm >] -> command interp state strm
and comment interp state = parser
  | [< ''\n'; strm >] -> eval interp state strm
  | [< ''\\'; strm >] -> ignore (backslash strm); comment interp state strm
  | [< '_;    strm >] -> comment interp state strm
  | [<        strm >] -> interp
and command interp state = parser
  | [< '']' when state.nest; >] -> invoke interp (argv_of_state state)
  | [< '';'|'\n'; strm >] ->
      eval (invoke interp (argv_of_state state)) (flush state) strm
  | [< ''\\'; strm >] ->
      command interp (state $^ backslash strm) strm
  | [< '' '|'\t'|'\r' when state.buf = ""; strm >] ->
      command interp state strm
  | [< '' '|'\t'|'\r'; strm >] -> command interp (add_arg state) strm
  | [< ''{'  when state.buf = ""; strm >] ->
      brace interp {state with openBraces = 1} strm
  | [< ''\"' when state.buf = ""; strm >] ->
      quote interp state strm
  | [< ''$'; strm >] ->
      command interp (state $^^ varsub interp "" strm) strm
  | [< ''['; strm >] ->
      let interp = cmdsub interp strm state in
      command interp (state $^^ interp.result) strm
  | [< 'c; strm >] -> command interp (state $^ c) strm
  | [< >] ->
      let argv = argv_of_state state in
      if argv = [] then
          interp
      else
          invoke interp argv
and brace interp state = parser
  | [< ''\\' as c; strm >] -> brace interp (state $^ c) strm
  | [< ''{'  as c; strm >] -> brace interp (incrbrace (state $^c)) strm
  | [< ''}'  as c; strm >] ->
      if state.openBraces = 1 then
          command interp (decrbrace (add_arg state)) strm
      else
          brace interp (decrbrace (state $^ c)) strm
  | [< 'c; strm >] -> brace interp (state $^ c) strm
  | [<     strm >] -> command interp state strm
and quote interp state = parser
  | [< ''\\'; strm >] -> quote interp (state $^ backslash strm) strm
  | [< ''\"'; strm >] -> command interp (add_arg state) strm
  | [< ''$';  strm >] -> quote interp (state $^^ varsub interp "" strm) strm
  | [< ''[';  strm >] -> let interp = cmdsub interp strm state in
                         quote interp (state $^^ interp.result) strm
  | [< 'c;    strm >] -> quote interp (state $^ c) strm
  | [<        strm >] -> command interp state strm
and cmdsub interp strm state =
  eval interp {openBraces = 0; argv = []; buf= "" ; nest = true;} strm

(* quick hack !! *)
let parse_as_list = function
  | "" -> []
  | s -> String.nsplit s " "

let register_builtins interp =
  let puts interp = function
    | str::[] -> (Printf.printf "%s\n" str; interp)
    | _ -> raise Wrong_number_of_args
  in
  let set interp = function
    | [name] -> {interp with result = var_lookup name interp}
    | [name; value] -> {var_update name value interp with result = value}
    | _ -> raise Wrong_number_of_args
  in
  let proc interp = function
    | name::formals::body::[] ->
      let formals' = parse_as_list formals in
      let proc = fun interp args ->
       let pairs = List.combine formals' args in
        let locals = List.fold_left (fun e (k, v) -> StringMap.add k (Value v) e) StringMap.empty pairs
        in
        let interp' = eval
          {interp with frames = locals::interp.frames}
          initial_state
          (Stream.of_string body)
        in
        {interp' with frames = uplevel 1 interp'.frames}
      in
      {interp with procs = (name, proc)::interp.procs}
    | _ -> raise Wrong_number_of_args
  in
  let global interp names =
    match interp.frames with
      | [] -> interp
      | frame::xs ->
        let frame' = List.fold_left (fun e k -> StringMap.add k Global e) frame names in
        {interp with frames = frame'::xs}
  in
  let upvar interp = function
    | [] -> raise Wrong_number_of_args
    | level::pairs ->
      let level' = int_of_string level in
      let rec upvar' level frame = function
        | other::my::xs ->
          let frame' = StringMap.add my (Upvar (other, level)) frame in
          upvar' level frame' xs
        | _ -> frame
      in
      let frame::xs = interp.frames in
      let frame' = upvar' level' frame pairs in
      {interp with frames = frame'::xs}
  in
  let procs = ["puts", puts; "set", set; "proc", proc; "global", global; "upvar", upvar] in
  {interp with procs = procs}

let inch = open_in Sys.argv.(1);;
let instr = Stream.of_channel inch;;
let interp = register_builtins initial_interp;;
eval interp initial_state instr

[1] http://code.google.com/p/hiccup/
[2] http://blog.so-net.ne.jp/rainyday/2006-10-21

ユニコード文字列のリテラルを使う

抽象データ型とリテラルというのがそもそも相容れないのかもしれないが Camomile の文字列型にはリテラルがない。ソースを書いた時点で固定的な情報をランタイムに計算するのはちょっと癪なのでいろいろ考えてみたのだけど、結局文字列型としては UTF8.t を、リテラルとしては通常の OCaml の文字列リテラルを使って abstraction barrier を破って UTF8.t と認識させるのが一番簡単であろうという結論に達した。

ただしこれだとソースファイルも UTF-8 で書かないといけないという問題がある。これを解決するために Java でいう native2ascii のような簡単なツールを作った。

(* wchar2latin.ml *)
open CamomileLibrary.Default.Camomile;;
open CamomileLibrary.Default.Camomile.CharEncoding;;
open Queue;;
open Printf;;

let from_encoding_name = ref "UTF-8";;
let files = Queue.create ();;

let set_from x = from_encoding_name := x in
let set_file x = Queue.add x files in
let spec = [("-encoding", Arg.String set_from, "Encoding of the source file")] in
Arg.parse spec set_file "usage:";;

let from_encoding = CharEncoding.of_name !from_encoding_name in
let in_chan =  if is_empty files then stdin  else open_in  (take files) in
let out_chan = if is_empty files then stdout else open_out (take files) in
let in_uchan = new CharEncoding.in_channel from_encoding in_chan in
try
  while true do
    let uc = in_uchan#get () in
    try
      output_char out_chan (UChar.char_of uc)
    with UChar.Out_of_range ->
      let s = UTF8.init 1 (fun _ -> uc) in
      String.iter (fun c -> fprintf out_chan "\\%03d" (int_of_char c)) s
  done
with End_of_file -> close_out out_chan

これを使うと任意の文字エンコーディングでリテラルが書かれたソースを UTF8 文字列とみなしてコンパイルできる。例えば以下のようなソースを書いてみる。

open CamomileLibrary.Default.Camomile;;

let a = "表示" in
  print_int (UTF8.length a);;

ここで「表示」は Shift_JIS とする。これをコンパイル、実行しても当然うまくいかない。

KURO-BOX% ocamlc bigarray.cma camomile.cma tryme.ml
File "tryme.ml", line 3, characters 10-12:
Warning X: illegal backslash escape in string.
KURO-BOX% ./a.out
Fatal error: exception Invalid_argument("UTF8.length")

先ほどのツールをプリプロセッサに使うとうまくいく。

KURO-BOX% ocamlc -pp './wchar2latin -encoding SHIFT_JIS' bigarray.cma camomile.cma tryme.ml
KURO-BOX% ./a.out
2

ツールが出力する生の情報としては以下のようになっている。

KURO-BOX% ./wchar2latin -encoding SHIFT_JIS tryme.ml
open CamomileLibrary.Default.Camomile;;

let a = "\232\161\168\231\164\186" in
  print_int (UTF8.length a);;

Camomile 使い方メモ (3) 文字列型の比較と操作

* Camomile のユニコード文字列概観

Camomile でユニコード文字列を扱うモジュールは UText, XString, UTF8, UTF16, UCS4 の5つがあります。
これらの違いとしてはまず

- UTF8, UTF16, UCS4 は immutable (ただし UTF8 は後述を参照)
- XString は mutable
- UText は両方ある (immutable: UText.utext, mutable: UText.ustring, これらは幽霊型で区別されている)

ということがあります。型としては UText.utext, UText.ustring, XString.xstring, UTF8.t, UTF16.t, UCS4.t の6種類になります。

mutable な2種類の文字列 (UText.ustring, XString.xstring) を比べた場合、

- UText.ustring は標準の string 型に近く、サイズの伸縮が不能
- XString モジュールにはサイズの伸縮が可能な関数が用意されている

という違いがあります。

UTF8 に固有の特徴として、UTF8.t は実は UTF-8 エンコーディングのバイト列が入った string 型であり、特に隠蔽もされていないため、標準の String モジュールを使って操作できるということがあげられます。
このため、他の文字列型と比べて外の世界との相互運用性が高いともいえます。
また String モジュールの関数を使うと UTF8 モジュールには提供されていない破壊的操作を行うこともできてしまいます。

また UTF8 と UTF16 は1文字あたりの長さが一意ではないためランダムアクセスの効率は他と比べて悪いはずです。

これ以降では各モジュールに提供されている関数の使い方を見ていきます。出現する例はすべてトップレベルで以下のように open している前提です。

open CamomileLibrary.Default.Camomile;;

種類	関数	UText	XString	UTF8	UTF16	UCS4
生成	init	○	○	○	○	○
	init_ustring	○	×	×	×	×
	of_string	○	×	×	×	×
	make	○	○	×	×	×
	copy	○	○	×	×	×
変換	utext_of_ustring	○	×	×	×	×
	ustring_of_utext	○	×	×	×	×
	utext_of	×	○	×	×	×
	ustring_of	×	○	×	×	×
長さ取得	length	○	○	○	○	○
位置指定アクセス	get	○	○	○	○	○
インデクスアクセス	look	○	○	○	○	○
	nth	○	○	○	○	○
	first	○	○	○	○	○
	last	○	○	○	○	○
	out_of_range	○	○	○	○	○
	compare_index	○	○	○	○	○
	next	○	○	○	○	○
	prev	○	○	○	○	○
	move	○	○	○	○	○
イテレーション	iter	○	○	○	○	○
比較	compare	○	○	○	○	○
検証	validate	×	×	○	○	○
非破壊的操作	sub	○	○	×	×	×
	append	○	○	×	×	×
破壊的操作	set	○	○	×	×	×
	fill	○	×	×	×	×
	blit	○	×	×	×	×
	clear	×	○	×	×	×
	reset	×	○	×	×	×
	add_char	×	○	×	×	×
	add_text	×	○	×	×	×
	add_xstring	×	○	×	×	×
	shrink	×	○	×	×	×

* 生成

全てのモジュールに共通の文字列生成方法として init 関数があります。
これは標準モジュールの Array.init と同様の高階関数で、引数として「文字の位置を与えられると UChar.t のユニコード文字を返す関数」を与えます。

# UTF8.init 10 (fun pos -> UChar.chr (pos + 0x0030));;
- : CamomileLibrary.Default.Camomile.UTF8.t = "0123456789"

UText.ustring の生成には UText.init_ustring を使います。使い方は同じです。

UText モジュールにだけは of_string 関数があり、これは Latin-1 文字列から変換して UText.utext 文字列を作ります。

# UText.of_string "Hello World!";;
- : CamomileLibrary.Default.Camomile.UText.utext = <abstr>

mutable な文字列 (UText.ustring, XString.xstring) は make 関数や copy 関数を使って生成することもできます。これは標準モジュールの String.make や String.copy と同様の使い方です。

(* 10文字の A から成る文字列を生成 *)
# XString.make 10 (UChar.chr 0x0041);;
- : CamomileLibrary.Default.Camomile.XString.xstring = <abstr>

* 変換

UText.utext と UText.ustring は utext_of_ustring と ustring_of_utext を使って相互変換することができます。

また、XString.xstring は XString.utext_of と XString.ustring_of を使ってそれぞれ UText.utext, UText.ustring に変換することができます。

* 長さの取得

全ての文字列型で、文字列長を取得する length 関数が使えます。これはバイト数ではなく文字数を返してくれます。

(* 全角の "０１２３４５６７８９" を生成して文字列長を取得 *)
# let s = UTF8.init 10 (fun pos -> UChar.chr (pos + 0x824f));;
val s : CamomileLibrary.Default.Camomile.UTF8.t =
  "\232\137\143\232\137\144\232\137\145\232\137\146\232\137\147\232\137\148\232\137\149\232\137\150\232\137\151\232\137\152"
# UTF8.length s;;
- : int = 10

* 位置指定のアクセス

全ての文字列型で、指定された位置の文字を返す get 関数が使えます。戻り値は UChar.t 型です。

(* "Hello World!" の6文字目 ('W' = U+0057 = 87) を取得 *)
# let ch = UText.get (UText.of_string "Hello World!") 6;;
val ch : CamomileLibrary.UChar.t = <abstr>
# UChar.code ch;;
- : int = 87

* インデクスによるアクセス

全ての文字列型でインデクスによるアクセスが提供されています。インデクスは文字列中の位置をポイントするカーソルのようなもので、進めたり、戻したり、その位置の文字を取得したりできます。インデクス自体は immutable な値で操作すると新しいオブジェクトが返ります。

# let str = UText.of_string "Hello World!";;
val str : CamomileLibrary.Default.Camomile.UText.utext = <abstr>
# let idx = UText.first str;;
val idx : CamomileLibrary.Default.Camomile.UText.index = <abstr>
#  UChar.code (UText.look str idx);;
- : int = 72
# let idx = UText.next str idx;;
val idx : CamomileLibrary.Default.Camomile.UText.index = <abstr>
# UChar.code (UText.look str idx);;
- : int = 101
# let idx = UText.move str idx 5;;
val idx : CamomileLibrary.Default.Camomile.UText.index = <abstr>
# UChar.code (UText.look str idx);;
- : int = 87
# let idx = UText.prev str idx;;
val idx : CamomileLibrary.Default.Camomile.UText.index = <abstr>
# UChar.code (UText.look str idx);;
- : int = 32
# let idx = UText.move str idx 999;;
val idx : CamomileLibrary.Default.Camomile.UText.index = <abstr>
# UText.out_of_range str idx;;
- : bool = true

get 関数と整数の位置情報でも代用できそうですが、文字列型によっては get 関数の実行に文字列長に依存したコストがかかる (UTF8, UTF16) ためインデクスを使用した方がよい場合があるということだと思います。

* イテレーション

全ての文字列型で iter 関数を使うことができます。これは標準モジュールの String.iter と同じで、各文字に対する処理を行うことができる高階関数です。第1引数には「UChar.t を取って何かをする関数」を与えます。

# let str = UText.of_string "Hello World!";;
val str : CamomileLibrary.Default.Camomile.UText.utext = <abstr>
# UText.iter (fun c -> print_int (UChar.code c); print_newline ()) str;;
72
101
108
108
111
32
87
111
114
108
100
33
- : unit = ()

* 比較

文字列の同値性は compare 関数で比較できます。全ての文字列型で使用できます。

# let str1 = UText.of_string "0123456789";;
val str1 : CamomileLibrary.Default.Camomile.UText.utext = <abstr>
# let str2 = UText.init 10 (fun pos -> UChar.chr (pos + 0x0030));;
val str2 : CamomileLibrary.Default.Camomile.UText.utext = <abstr>
# UText.compare str1 str2;;
- : int = 0

* 検証

UTF8, UTF16, UCS4 については validate 関数を使って各々のエンコーディングとして正当な表現になっているかの検証を行うことできます。不正だった場合は例外 Malformed_code が投げられます。

# UTF8.validate "\xff";;
Exception: UTF8.Malformed_code.

* 非破壊的操作

UText と XString には sub 関数と append 関数が用意されています。標準モジュールの String.sub と String.append と同様に使えます。

(* "0123456789" の4文字目から6文字分を取得 *)
# let str1 = UText.of_string "0123456789";;
val str1 : CamomileLibrary.Default.Camomile.UText.utext = <abstr>
# let str2 = UText.sub str1 3 6;;
val str2 : [ `Immutable ] CamomileLibrary.Default.Camomile.UText.text =
  <abstr>
# UText.compare str2 (UText.of_string "345678");;
- : int = 0

(* "Hello " と "World!" を連結 *)
# let str = UText.of_string "Hello World!";;
val str : CamomileLibrary.Default.Camomile.UText.utext = <abstr>
# let hello = UText.of_string "Hello ";;
val hello : CamomileLibrary.Default.Camomile.UText.utext = <abstr>
# let world = UText.of_string "World!";;
val world : CamomileLibrary.Default.Camomile.UText.utext = <abstr>
# UText.compare str (UText.append hello world);;
- : int = 0

* 破壊的操作: set

UText.ustring と XString には set 関数が用意されています。これは標準モジュールの String.set と同じで、指定位置の文字を破壊的に書き換えます。

* 破壊的操作: fill, blit

UText.ustring には fill 関数と blit 関数が用意されています。これは標準モジュールの String.fill, String.blit と同じで、文字列の指定範囲を与えられた文字ないし文字列で書き換えます。

(* "fork" の2文字目から2文字分を '*'=U+002A で置き換える *)
# let str1 = UText.ustring_of_utext (UText.of_string "fork");;
val str1 : CamomileLibrary.Default.Camomile.UText.ustring = <abstr>
# UText.fill str1 1 2 (UChar.chr 0x002a);;
- : unit = ()
# let f2 = UText.ustring_of_utext (UText.of_string "f**k");;
val f2 : CamomileLibrary.Default.Camomile.UText.ustring = <abstr>
# UText.compare f f2;;
- : int = 0

(* "Hello World!" を "Howdy World!" に書き換える *)
# let str1 = UText.ustring_of_utext (UText.of_string "Hello World!");;
val str1 : CamomileLibrary.Default.Camomile.UText.ustring = <abstr>
# let str2 = UText.of_string "Howdy";;
val str2 : CamomileLibrary.Default.Camomile.UText.utext = <abstr>
# UText.blit str2 0 str1 0 5;;
- : unit = ()
# let str3 = UText.ustring_of_utext (UText.of_string "Howdy World!");;
val str3 : CamomileLibrary.Default.Camomile.UText.ustring = <abstr>
# UText.compare str1 str3;;
- : int = 0

* 破壊的操作: clear, reset, add_char, add_text, add_xstring, shrink

XString だけに存在する関数として clear, reset, add_char, add_text, add_xstring, shrink があります。それぞれ関数名から期待されるような破壊的操作を行います。

# let str = XString.init 10 (fun pos -> UChar.chr (pos + 0x0030));;
val str : CamomileLibrary.Default.Camomile.XString.xstring = <abstr>
# XString.add_char str (UChar.chr 0x002a);;
- : unit = ()
# XString.length str;;
- : int = 11
# XString.add_text str (UText.of_string "ABC");;
- : unit = ()
# XString.length str;;
- : int = 14
# XString.shrink str 10;;
- : unit = ()
# XString.length str;;
- : int = 10
# XString.clear str;;
- : unit = ()
# XString.length str;;
- : int = 0

clear と reset の違いはどうやら clear は内部的には長さ情報を 0 にするだけで reset のほうは既存の内部メモリ領域も捨てて新しくするようです。

Camomile 使い方メモ (2)

Camomile についてさらに調べる。

Camomile のユニコード文字列型には何種類かあるけれども文字型は UChar という1つしかない。

特定のエンコーディングで書かれたテキストファイルから読み込むには以下のようにする。hyoji.txt は Shift_JIS で「表示」の2文字だけが書かれたファイルとする。

# let inc = open_in "hyoji.txt";;
val inc : in_channel = <abstr>
# let sjis = CamomileLibrary.Default.Camomile.CharEncoding.of_name "SHIFT_JIS";;
val sjis : CamomileLibrary.Default.Camomile.CharEncoding.t = <abstr>
# let inc' = new CamomileLibrary.Default.Camomile.CharEncoding.in_channel sjis inc;;
val inc' : CamomileLibrary.Default.Camomile.CharEncoding.in_channel = <obj>
# let hyo = inc'#get ();;
val hyo : CamomileLibrary.UChar.t = <abstr>
# let ji = inc'#get ();;
val ji : CamomileLibrary.UChar.t = <abstr>
# inc'#get ();;
Exception: End_of_file.

new CharEncoding.in_channel で得られるオブジェクトは普通の入力チャネルを UChar 型単位のチャネルに変換したもの。このオブジェクトから get メソッドで1文字ずつ取得することができる。UChar 型として2文字を読んだところで EOF になっているのが分かる。

このオブジェクトは OOChannel.stream_of_channel 関数を使って Stream.t 型にすることもできる。馴染み深い分こちらのインターフェイスのほうが使いやすいこともあるだろう。

# CamomileLibrary.Default.Camomile.OOChannel.stream_of_channel inc';;
- : CamomileLibrary.UChar.t Stream.t = <abstr>

ところで UChar.code 関数を使うと UChar 型の値をユニコードのコードを示す整数に変換できる。
先に取得した「表示」の2文字がそれぞれユニコードで U+8868 と U+793A であることを確かめてみよう。

# Printf.sprintf "%x" (CamomileLibrary.Default.Camomile.UChar.code hyo);;
- : string = "8868"
# Printf.sprintf "%x" (CamomileLibrary.Default.Camomile.UChar.code ji);;
- : string = "793a"

UChar のチャネルなりストリームなりから得た文字を UTF8 や UText などの文字列にするにはどうしたらよいか。一つは UChar のチャネルを変換してユニコード文字列の行から成るチャネルにする方法がある。

# module L = CamomileLibrary.Default.Camomile.ULine.Make(CamomileLibrary.UTF8);;
module L :
  sig
    type text = CamomileLibrary.UTF8.t
    class input_line :
      CamomileLibrary.UChar.t #CamomileLibrary.OOChannel.obj_input_channel ->
      [text] CamomileLibrary.OOChannel.obj_input_channel
    class output_line :
      ?sp:CamomileLibrary.Default.Camomile.ULine.separator ->
      CamomileLibrary.UChar.t #CamomileLibrary.OOChannel.obj_output_channel ->
      [text] CamomileLibrary.OOChannel.obj_output_channel
  end
# let l = new L.input_line inc';;
val l : L.input_line = <obj>
# let line =  l#get ();;
val line : L.text = "\232\161\168\231\164\186"
# CamomileLibrary.UTF8.length line;;
- : int = 2
# let line =  l#get ();;
Exception: End_of_file.

ULine はファンクタで、使いたいユニコード文字列型に適用して具体的なモジュールを得る。
得られたモジュールの input クラスを使うと UChar のチャネルをユニコード文字列の行単位のチャネルに変換できる。

もう一つはユニコード文字列型には Buf サブモジュールで文字列バッファが提供されているのでそれをつかってもよいかもしれない。

# let buf = CamomileLibrary.UTF8.Buf.create 256;;
val buf : CamomileLibrary.UTF8.Buf.buf = <abstr>
# while true do CamomileLibrary.UTF8.Buf.add_char buf (inc'#get ()) done;;
Exception: End_of_file.
# let s = CamomileLibrary.UTF8.Buf.contents buf;;
val s : CamomileLibrary.UTF8.t = "\232\161\168\231\164\186"
# CamomileLibrary.UTF8.length s;;
- : int = 2

ここまで分かればもう大抵のやりたいことはできそうかなあ。出力側はまあ似たような感じだろう。

Camomile 使い方メモ

Camomile について調べたメモ。

普通の文字列型 (string) と Camomile 内部のユニコード文字列型との間の変換を行うエンコーダ/デコーダを作る。内部エンコーディングとして UTF-8 を使う場合は以下のようにする。UTF8 以外にも UText, XString, UTF16, UCS4 が選べるようだ。

KURO-BOX% ocaml bigarray.cma camomile.cma
        Objective Caml version 3.10.0

# module U = CamomileLibrary.Default.Camomile.CharEncoding.Make(CamomileLibrary.UTF8);;
module U :
  sig
    type text = CamomileLibrary.UTF8.t
    val decode :
      CamomileLibrary.Default.Camomile.CharEncoding.t -> string -> text
    val encode :
      CamomileLibrary.Default.Camomile.CharEncoding.t -> text -> string
  end

外部エンコーディングからこの UTF-8 に変換を行うには decode 関数を使う。この第1引数は変換元エンコーディングを示す型の値。これは CamomileLibrary.Default.Camomile.CharEncoding.of_name で取得できる。

# let sjis = CamomileLibrary.Default.Camomile.CharEncoding.of_name "SHIFT_JIS";;
val sjis : CamomileLibrary.Default.Camomile.CharEncoding.t = <abstr>

以下は Shift_JIS の「表示」という文字列を UTF-8 に変換する。

# let hyoji_sjis = "\x95\x5c\x8e\xa6";;
val hyoji_sjis : string = "\149\\\142\166"
# let hyoji_utf8 = U.decode sjis hyoji_sjis;;
val hyoji_utf8 : U.text = "\232\161\168\231\164\186"

この値には CamomileLibrary.UTF8 モジュールの関数を使うことができる。例えば CamomileLibrary.UTF8.length 関数を使うと正しく文字数を2文字と判断してくれる。

# CamomileLibrary.UTF8.length hyoji_utf8;;
- : int = 2

ここから他の文字エンコーディングに変換するには encode 関数を使う。

# let eucjp = CamomileLibrary.Default.Camomile.CharEncoding.of_name "EUC-JP";;
val eucjp : CamomileLibrary.Default.Camomile.CharEncoding.t = <abstr>
# let hyoji_eucjp = U.encode eucjp hyoji_utf8;;
val hyoji_eucjp : string = "\201\189\188\168"

Camlp4 3.10 のさわり (2)

* ロードされている Camlp4 モジュールを調べる。

Camlp4.Register.loaded_modules を見る。これは参照型でモジュールがロードされるときに改変されるようだ。

KURO-BOX% ocaml
        Objective Caml version 3.10.0

# #load "camlp4o.cma";;
        Camlp4 Parsing version 3.10.0

# !Camlp4.Register.loaded_modules;;
- : string list =
["Camlp4OCamlParserParser"; "Camlp4OCamlRevisedParserParser";
 "Camlp4OCamlParser"; "Camlp4RevisedParserParser"]
# #load "camlp4oof.cma";;
        Camlp4 Parsing version 3.10.0

# !Camlp4.Register.loaded_modules;;
- : string list =
["Camlp4ListComprenhsion"; "Camlp4MacroParser"; "Camlp4MacroParser";
 "Camlp4GrammarParser"; "Camlp4OCamlParserParser";
 "Camlp4OCamlRevisedParserParser"; "Camlp4OCamlParser";
 "Camlp4RevisedParserParser"]

* エントリの内容を表示する

Camlp4 3.9 では Grammar.Entry.print 関数を使って「Grammar.Entry.print Pcaml.str_item;;」とかやっていたけど Camlp4 3.10 では ocaml トップレベルのプリティプリンタになっているのでプリティプリンタをインストールして値を打つだけでよい。

# #load "camlp4o.cma";;
        Camlp4 Parsing version 3.10.0

# #install_printer Camlp4.PreCast.Gram.Entry.print;;
# Camlp4.PreCast.Syntax.str_item;;
- : Camlp4.PreCast.Syntax.Ast.str_item Camlp4.PreCast.Syntax.Gram.Entry.t =
str_item: [ "top" LEFTA
  [ "let"; "module"; a_UIDENT; module_binding0; "in"; expr
  | "let"; opt_rec; binding; "in"; expr
  | "let"; opt_rec; binding
  | "exception"; constructor_declaration; "="; type_longident
  | "exception"; constructor_declaration
  | "external"; a_LIDENT; ":"; ctyp; "="; string_list
  | "include"; module_expr
  | "module"; "rec"; module_binding
  | "module"; "type"; a_UIDENT; "="; module_type
  | "module"; a_UIDENT; module_binding0
  | "open"; module_longident
  | "type"; type_declaration
  | "class"; "type"; class_type_declaration
  | "class"; class_declaration
  | ANTIQUOT (("" | "stri" | "anti" | "list"), _)
  | QUOTATION _
  | expr ] ]

* エントリ指定でのパーシング

KURO-BOX% ocaml
        Objective Caml version 3.10.0

# #load "camlp4o.cma";;
        Camlp4 Parsing version 3.10.0

# Camlp4.PreCast.Syntax.Gram.parse_string Camlp4.PreCast.Syntax.str_item Camlp4.PreCast.Loc.ghost "let _ = 1";;
- : Camlp4.PreCast.Syntax.Ast.str_item =
Camlp4.PreCast.Syntax.Ast.StExp (<abstr>,
 Camlp4.PreCast.Syntax.Ast.ExInt (<abstr>, "1"))

Camlp4 3.10 のさわり

そろそろ Camlp4 3.10 を調べていこうかと思った。

* Camlp4 で何もしない

OCaml ソースを構文木にしてさらに OCaml コードに戻すだけのコマンドラインは以下のようになる。

camlp4 -parser OCaml -printer OCaml tryme.ml

これは以下と同じ

camlp4 Camlp4OCamlParser.cmo Camlp4OCamlPrinter.cmo tryme.ml

以前の Camlp4 では出力でコードに戻す場合と構文木のままダンプしてコンパイラに渡す場合でプリンタを変えなければいけなかったけど 3.10 では -printer Auto とすると適宜に選んでくれる。

camlp4 -parser OCaml -printer Auto tryme.ml # この場合コードを出力

ocamlc -pp 'camlp4 -parser OCaml -printer Auto' tryme.ml # この場合構文木のダンプ

* 付属の構文拡張を使ってみる

Camlp4 3.10 には Haskell 風のリスト内包表記が書ける構文がついてくる。

KURO-BOX% ocaml -I +camlp4/Camlp4Parsers
        Objective Caml version 3.10.0

# #load "camlp4o.cma";;
        Camlp4 Parsing version 3.10.0

# #load "Camlp4ListComprehension.cmo";;
# [x * 2 | x <- [1; 2; 3] ];;
- : int list = [2; 4; 6]
# [x | x <- [1; 2; 3; 4; 5; 6]; x mod 2 = 0];;
- : int list = [2; 4; 6]
# [(x, y) | x <- [1; 2; 3]; y <- ['a'; 'b'; 'c'] ];;
- : (int * char) list =
[(1, 'a'); (1, 'b'); (1, 'c'); (2, 'a'); (2, 'b'); (2, 'c'); (3, 'a');
 (3, 'b'); (3, 'c')]

* 構文木の姿を捉える

Camlp4.PreCast.Syntax.parse_implem 関数で OCaml ソースを構文木に変換できる。これは 3.9 のときと違って参照型ではない。どういう設計に変わったのかな？

KURO-BOX% ocaml
        Objective Caml version 3.10.0

# #load "camlp4o.cma";;
        Camlp4 Parsing version 3.10.0

# Camlp4.PreCast.Syntax.parse_implem Camlp4.PreCast.Loc.ghost (Stream.of_string "let _ = 1");;
- : Camlp4.PreCast.Syntax.Ast.str_item =
Camlp4.PreCast.Syntax.Ast.StExp (<abstr>,
 Camlp4.PreCast.Syntax.Ast.ExInt (<abstr>, "1"))

* クォーテーションを使う

camlp4oof を使うとクォーテーションも使えるようになる。

KURO-BOX% ocaml
        Objective Caml version 3.10.0

# #load "camlp4oof.cma";;
        Camlp4 Parsing version 3.10.0

# open Camlp4.PreCast;;
# let _loc = Camlp4.PreCast.Loc.ghost;;
val _loc : Camlp4.PreCast.Loc.t = <abstr>
# <:str_item< print_string "Hello World!" >>;;
- : Camlp4.PreCast.Ast.str_item =
Camlp4.PreCast.Ast.StSem (<abstr>,
 Camlp4.PreCast.Ast.StExp (<abstr>,
  Camlp4.PreCast.Ast.ExApp (<abstr>,
   Camlp4.PreCast.Ast.ExId (<abstr>,
    Camlp4.PreCast.Ast.IdLid (<abstr>, "print_string")),
   Camlp4.PreCast.Ast.ExStr (<abstr>, "Hello World!"))),
 Camlp4.PreCast.Ast.StNil <abstr>)

とりあえずここまで。

幽霊型を使ってウェブアプリで安全に文字列を使う

以前 Joel on Software の「間違ったコードは間違って見えるようにする」という記事 [1] を読んだ。彼はこの記事の中でハンガリアン記法のうち変数のデータ型/タイプ (type) を示すに過ぎない「システムハンガリアン」を否定する一方で、タイプでは区別できないような種類 (kind) を示す「アプリケーションハンガリアン」を支持している。

この記事にはとても感心したのだけど、彼の出している「安全な文字列」と「安全でない文字列」の例をみてこうも思った。このくらいのことなら面倒見てくれるコンパイラやツールがあったっていいんじゃないだろうか。種類とタイプの違いというのは先験的にあるもの（と Joel Spolsky が書いているわけではないが）じゃなくて、コンパイラや IDE などのツールがサポートするところまでがタイプで、残りが種類なんじゃないだろうか。

とはいえ、口で言えても実際にそういうチェックを実装するのは大変そうだなと思っていたのだけど、最近購入した「入門 OCaml」にまさにこの問題へのソリューションが提示されていた。幽霊型という手法らしい。

本で例に挙げているのは「税抜き金額」と「税込み金額」の型を区別して「税込み金額に課税関数を適用できない」とか「税抜き金額と税込み金額を足し合わせることはできない」という制約をつけるものだけど、解説の終わりで「例えばWebインターフェイスから送られてきたデータをサーバ側でセキュリティチェックする際などに、[`Dirty] string と [`Clean] stringに区別できれば、不安な要素が1つ減らすことができます。」とある。これだ！というわけでざっくり作ってみた。

(* webString.mli *)

type 'a t constraint 'a = [< `Plain | `Html | `Sql | `Url ]

val make : string -> [`Plain] t
val make_html : string -> [`Html] t
val make_sql : string -> [`Sql] t
val make_url : string -> [`Url] t

val to_html : [`Plain] t -> [`Html] t
val to_sql : [`Plain] t -> [`Sql] t

val url_of_plain : [`Plain] t -> [`Url] t
val plain_of_url : [`Url] t -> [`Plain] t

val print : Format.formatter -> [`Plain] t -> unit
val print_html : Format.formatter -> [`Html] t -> unit
val print_sql : Format.formatter -> [`Sql] t -> unit
val print_url : Format.formatter -> [`Url] t -> unit

val (^) : 'a t -> 'a t -> 'a t

(* webString.ml *)

open ExtString

type 'a t = string constraint 'a = [< `Plain | `Html | `Sql | `Url ]

let make s = s
let make_html s = s
let make_sql s = s
let make_url s = s

let to_html s =
  let escape = function
  | '<' -> "&lt;"
  | '>' -> "&gt;"
  | '&' -> "&amp;"
  | c   -> String.make 1 c
  in
  String.replace_chars escape s

let to_sql s =
  let escape = function
  | '\'' -> "''"
  | c   -> String.make 1 c
  in
  String.replace_chars escape s

let plain_of_url = Cgi.decode
let url_of_plain = Cgi.encode

let print p s = Format.print_string ("\"" ^ (String.escaped s) ^ "\"")
let print_html p s = Format.print_string ("\"" ^ (String.escaped s) ^ "\"")
let print_sql p s = Format.print_string ("\"" ^ (String.escaped s) ^ "\"")
let print_url p s = Format.print_string ("\"" ^ (String.escaped s) ^ "\"")

let (^) x y = x ^ y

ウェブアプリケーションで使用することを考えると Dirty と Clean の2種類よりはプレーン文字列、HTML文字列、SQL文字列、URLエンコード文字列の4種類くらいはあったほうがよさそうなのでそうした。コード中の Cgi モジュールは [2] で手に入るものを使っている。
これを使ってみた結果は以下のとおり。

KURO-BOX% ocaml
        Objective Caml version 3.09.2

# #load "str.cma";;
# #load "cgi.cmo";;
# #load "extlib/extLib.cma";;
# #load "webString.cmo";;
# open WebString;;
# #install_printer print;;
# #install_printer print_html;;
# #install_printer print_url;;
# let input = make_url "%3Cscript%3E%3C%2Fscript%3E";; (* 1 *)
val input : [ `Url ] WebString.t = "%3Cscript%3E%3C%2Fscript%3E"
# let decoded = plain_of_url input;;
val decoded : [ `Plain ] WebString.t = "<script></script>"
# let output = (make_html "<html>") ^ decoded ^ (make_html "</html>");; (* 2 *)
This expression has type [ `Html ] WebString.t but is here used with type
  [ `Plain ] WebString.t
These two variant types have no intersection
# let output = (make_html "<html>") ^ (to_html decoded) ^ (make_html "</html>");; (* 3 *)
val output : [ `Html ] WebString.t =
  "<html>&lt;script&gt;&lt;/script&gt;</html>"

(* 1 ユーザからの入力は最初 [ `Url ] WebString.t 型で与えられるものとする *)
(* 2 [ `Plain ] WebString.t 型は [ `Html ] WebString.t 型と一緒に使うことはできない *)
(* 3 to_html 関数を使って [ `Html ] WebString.t に変換すると安全に [ `Html ] WebString.t 型と連結できる *)

なかなかいい感じ。OCaml は奥が深いなあ。あとは文字コード変換をどうからめるかが課題か。

[1] http://local.joelonsoftware.com/mediawiki/index.php/%E9%96%93%E9%81%95%E3%81%A3%E3%81%9F%E3%82%B3%E3%83%BC%E3%83%89%E3%81%AF%E9%96%93%E9%81%95%E3%81%A3%E3%81%A6%E8%A6%8B%E3%81%88%E3%82%8B%E3%82%88%E3%81%86%E3%81%AB%E3%81%99%E3%82%8B
[2] http://www.lri.fr/~filliatr/ftp/ocaml/cgi/