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

ちょっと前に書いた Tcl インタプリタ [1] を Camlp4 のストリームパーサを使って書き直してみた。他にもスタイル的な部分でちょこちょこと変えた。

最初ガード条件をどうやって書けばいいのか分からなくて詰まった。

module StringMap = Map.Make(String)
exception Unknown_command

type interp = {
    result : string;
    g : string StringMap.t;
}

type state = {
    openBraces : int;
    argv : string list;
    buf : string;
    nest : bool;
}

let string_of_char c = String.make 1 c

let invoke interp argv = 
    let argv = List.rev argv in
    match argv with
    | "puts"::str::[] -> Printf.printf "%s\n" str; interp
    | "set"::name::[] -> {interp with result = StringMap.find name interp.g}
    | "set"::name::value::[] -> {g = StringMap.add name value interp.g; result = value}
    | _ -> 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 StringMap.find name interp.g

let argv_of_state state =
    if state.buf="" then state.argv else state.buf::state.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}

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

let inch = open_in Sys.argv.(1);;
let instr = Stream.of_channel inch;;
let _ = eval {result = ""; g = StringMap.empty}
             {openBraces = 0; argv = []; buf=""; nest = false;}
             instr;;

[1] http://blog.so-net.ne.jp/rainyday/2006-09-25