TaPLのコード解説(Chapter4)
TaPL(Types and Programming Language)を読んでいるとOCamlのサンプルコードが載っている章があります。
これら章には型は書いてあるものの、Lexerや、Parserなどについては書いておりません。そのため、HPからImplementationsに飛ぶとソースコードが載っています。そこで完全なコードが書かれています。
英語でコメントも付いていますが、まずは概観が理解ができるように本記事を書いています。
初回の今回はChapter4のコードに関して触れていきます。
コードは私がホームページから持ってきて、日本語でコメントしたものをGitHubに置いており、そちらから抜粋したコードをここでは載せています。
まず、本文にあるMakefile
によるビルドよりも記述が簡単(主観)なDune
を使うようにしてみました。
dune
以下のように記述するとMakefile
いらずで起動ができます。
パット見、dune
で使われている文法は目新しいかもしれませんが、構文木をそのまま書いているだけで、target
は生成ファイルでdeps
が依存ファイル。action
で実際にどうするかを記述しています。env
の部分はビルド時のwarningを抑えるためのフラグが書かれています。
(rule
(target lexer.ml)
(deps lexer.mll)
(action
(chdir
%{workspace_root}
(run %{bin:ocamllex} -q -o %{target} %{deps}))))
(rule
(targets parser.ml parser.mli)
(deps parser.mly)
(action
(chdir
%{workspace_root}
(run %{bin:ocamlyacc} %{deps}))))
(env
(dev
(flags
(:standard -w -a))))
(executable
(name main))
また、dune-project
は生成時のまま使っています。
(lang dune 2.9)
全体像
各ファイルの説明
このプロジェクトではdune
、dune-project
、.ocamlformat
とテストで使うtest.f
を除くと.ml
、.mli
、.mll
、.mly
の4つの拡張子の付いたファイルがあります。
.ml
は実装ファイルで定義を書きます。
.mli
はインターフェースファイルで、仕様を書きます。
.mll
はocamllexというソフトが字句解析プログラムを生成するのに使います。
.mly
はocamlyaccというソフトが構文解析プログラムを生成するのに使います。
このうち.mli
のみコメントがありしっかりと作者は理解をしてほしそうです。ということで、今回はこちらのファイルに焦点を絞って解説をします。
4種類の総行数は次の通りで短いです。
❯ fd "(ml|mli|mll|mly)$" | xargs wc -l
49 core.ml
9 core.mli
216 lexer.mll
100 main.ml
141 parser.mly
73 support.ml
57 support.mli
102 syntax.ml
24 syntax.mli
771 total
依存関係の順に説明していきます。
support.ml
support.mli
ここでは各種ファイルで使われる関数が書かれています。
最初はPervasive
というサブモジュールのインターフェースを制限しています。ここではpr
のシグネチャが書かれています。これは標準出力に使われており、短縮して呼び出せるようにしています。
(* module Support
Collects a number of low-level facilities used by the other modules
in the typechecker/evaluator.
*)
(* ------------------------------------------------------------------------ *)
(* Some pervasive abbreviations -- opened everywhere by convention *)
(* 短縮形の定義 *)
module Pervasive : sig
val pr : string -> unit
end
次の部分ではError
というサブモジュールのインターフェースを制限しています。
最初にファイル情報に関する型や関数仕様を書いています。
(* ------------------------------------------------------------------------ *)
(* Error printing utilities -- opened everywhere by convention *)
module Error : sig
(* An exception raised by the low-level error printer; exported
here so that it can be caught in module Main and converted into
an exit status for the whole program. *)
(* ポインタに関するエラーが生じた際に使う例外 *)
exception Exit of int
(* An element of the type info represents a "file position": a
file name, line number, and character position within the line.
Used for printing error messages. *)
(* ファイル情報に関する要素に使う型 *)
type info
(* ダミーに使われる値 *)
val dummyinfo : info
(* Create file position info: filename lineno column *)
(* ファイル情報に関するデータを作る関数 *)
val createInfo : string -> int -> int -> info
(* ファイル情報を出力する関数 *)
val printInfo : info -> unit
次の部分はパーサーで用いるファイル情報の型やそれに関する関数の仕様が書かれています。
(* A convenient datatype for a "value with file info." Used in
the lexer and parser. *)
(* パーサーで用いるファイル情報に関する型 *)
type 'a withinfo = { i : info; v : 'a }
(* Print an error message and fail. The printing function is called
in a context where the formatter is processing an hvbox. Insert
calls to Format.print_space to print a space or, if necessary,
break the line at that point. *)
(* エラーメッセージを出してプログラムを終了する *)
val errf : (unit -> unit) -> 'a
(* エラーがどこで起きたかを出力 *)
val errfAt : info -> (unit -> unit) -> 'a
(* Convenient wrappers for the above, for the common case where the
action to be performed is just to print a given string. *)
(* 上の関数をまとめる関数 *)
val err : string -> 'a
(* 同上 *)
val error : info -> string -> 'a
(* Variants that print a message but do not fail afterwards *)
(* 上の場合はプログラムが終了するが警告だけで終了はしない *)
val warning : string -> unit
(* 警告がどこで起きたかを出力 *)
val warningAt : info -> string -> unit
end
support.ml
ではそれらの実装が書かれています。
open Format
module Error = struct
exception Exit of int
type info = FI of string * int * int | UNKNOWN
type 'a withinfo = { i : info; v : 'a }
let dummyinfo = UNKNOWN
let createInfo f l c = FI (f, l, c)
let errf f =
print_flush ();
open_vbox 0;
open_hvbox 0;
f ();
print_cut ();
close_box ();
print_newline ();
raise (Exit 1)
let printInfo =
(* In the text of the book, file positions in error messages are replaced
with the string "Error:" *)
function
| FI (f, l, c) ->
print_string f;
print_string ":";
print_int l;
print_string ".";
print_int c;
print_string ":"
| UNKNOWN -> print_string "<Unknown file and line>: "
let errfAt fi f =
errf (fun () ->
printInfo fi;
print_space ();
f ())
let err s =
errf (fun () ->
print_string "Error: ";
print_string s;
print_newline ())
let error fi s =
errfAt fi (fun () ->
print_string s;
print_newline ())
let warning s =
print_string "Warning: ";
print_string s;
print_newline ()
let warningAt fi s =
printInfo fi;
print_string " Warning: ";
print_string s;
print_newline ()
end
(* ---------------------------------------------------------------------- *)
module Pervasive = struct
type info = Error.info
let pr = Format.print_string
end
(* module pervasive *)
lexer.mll
parser.mly
これはocamllexとocamlyaccというレクサー、パーサーのコードを生成するツールに関するコードです。
ocamllex
の基本的な文法は以下のようになっています。
{ header }
let ident = regexp …
[refill { refill-handler }]
rule entrypoint [arg1… argn] =
parse regexp { action }
| …
| regexp { action }
and entrypoint [arg1… argn] =
parse …
and …
{ trailer }
最初と最後に{}
で囲まれたheaderとtrailerがあり、ヘッダーでは予約語を決めています。
header
とentrypoint
の間にはident
というよく使う正規表現が定義できます。これを書くことで後で労力を節約できるというわけです。TaPLのサンプルコードではここに関数がまとめられています。
entrypoint
では実際に字句解析する際の文法を正規表現で書き、その際に実行する処理を{ action }
内に書きます。正規表現は最大までマッチするようになっています。
細かい文法はHPを参照ください。
(*
The lexical analyzer: lexer.ml is generated automatically
from lexer.mll.
The only modification commonly needed here is adding new keywords to the
list of reserved words at the top.
*)
{
open Support.Error
(* 予約語 *)
let reservedWords = [
(* Keywords *)
(* 予約キーワード *)
("import", fun i -> Parser.IMPORT i);
("if", fun i -> Parser.IF i);
("then", fun i -> Parser.THEN i);
("else", fun i -> Parser.ELSE i);
("true", fun i -> Parser.TRUE i);
("false", fun i -> Parser.FALSE i);
("succ", fun i -> Parser.SUCC i);
("pred", fun i -> Parser.PRED i);
("iszero", fun i -> Parser.ISZERO i);
(* 予約記号 *)
(* Symbols *)
("_", fun i -> Parser.USCORE i);
("'", fun i -> Parser.APOSTROPHE i);
("\"", fun i -> Parser.DQUOTE i);
("!", fun i -> Parser.BANG i);
("#", fun i -> Parser.HASH i);
("$", fun i -> Parser.TRIANGLE i);
("*", fun i -> Parser.STAR i);
("|", fun i -> Parser.VBAR i);
(".", fun i -> Parser.DOT i);
(";", fun i -> Parser.SEMI i);
(",", fun i -> Parser.COMMA i);
("/", fun i -> Parser.SLASH i);
(":", fun i -> Parser.COLON i);
("::", fun i -> Parser.COLONCOLON i);
("=", fun i -> Parser.EQ i);
("==", fun i -> Parser.EQEQ i);
("[", fun i -> Parser.LSQUARE i);
("<", fun i -> Parser.LT i);
("{", fun i -> Parser.LCURLY i);
("(", fun i -> Parser.LPAREN i);
("<-", fun i -> Parser.LEFTARROW i);
("{|", fun i -> Parser.LCURLYBAR i);
("[|", fun i -> Parser.LSQUAREBAR i);
("}", fun i -> Parser.RCURLY i);
(")", fun i -> Parser.RPAREN i);
("]", fun i -> Parser.RSQUARE i);
(">", fun i -> Parser.GT i);
("|}", fun i -> Parser.BARRCURLY i);
("|>", fun i -> Parser.BARGT i);
("|]", fun i -> Parser.BARRSQUARE i);
(* Special compound symbols: *)
(* 上の記号が複数結合してできた記号 *)
(":=", fun i -> Parser.COLONEQ i);
("->", fun i -> Parser.ARROW i);
("=>", fun i -> Parser.DARROW i);
("==>", fun i -> Parser.DDARROW i);
]
(* Support functions *)
(* 諸々の補助関数 *)
type buildfun = info -> Parser.token
let (symbolTable : (string,buildfun) Hashtbl.t) = Hashtbl.create 1024
let _ =
List.iter (fun (str,f) -> Hashtbl.add symbolTable str f) reservedWords
let createID i str =
try (Hashtbl.find symbolTable str) i
with _ ->
if (String.get str 0) >= 'A' && (String.get str 0) <= 'Z' then
Parser.UCID {i=i;v=str}
else
Parser.LCID {i=i;v=str}
let lineno = ref 1
and depth = ref 0
and start = ref 0
and filename = ref ""
and startLex = ref dummyinfo
let create inFile stream =
if not (Filename.is_implicit inFile) then filename := inFile
else filename := Filename.concat (Sys.getcwd()) inFile;
lineno := 1; start := 0; Lexing.from_channel stream
let newline lexbuf = incr lineno; start := (Lexing.lexeme_start lexbuf)
let info lexbuf =
createInfo (!filename) (!lineno) (Lexing.lexeme_start lexbuf - !start)
let text = Lexing.lexeme
let stringBuffer = ref (Bytes.create 2048)
let stringEnd = ref 0
let resetStr () = stringEnd := 0
let addStr ch =
let x = !stringEnd in
let buffer = !stringBuffer
in
if x = Bytes.length buffer then
begin
let newBuffer = Bytes.create (x*2) in
Bytes.blit buffer 0 newBuffer 0 x;
Bytes.set newBuffer x ch;
stringBuffer := newBuffer;
stringEnd := x+1
end
else
begin
Bytes.set buffer x ch;
stringEnd := x+1
end
let getStr () = Bytes.sub_string (!stringBuffer) 0 (!stringEnd)
let extractLineno yytext offset =
int_of_string (String.sub yytext offset (String.length yytext - offset))
}
(* The main body of the lexical analyzer *)
(* 字句解析 *)
rule main = parse
[' ' '\009' '\012']+ { main lexbuf }
| [' ' '\009' '\012']*"\n" { newline lexbuf; main lexbuf }
| "*/" { error (info lexbuf) "Unmatched end of comment" }
| "/*" { depth := 1; startLex := info lexbuf; comment lexbuf; main lexbuf }
| "# " ['0'-'9']+
{ lineno := extractLineno (text lexbuf) 2 - 1; getFile lexbuf }
| "# line " ['0'-'9']+
{ lineno := extractLineno (text lexbuf) 7 - 1; getFile lexbuf }
| ['0'-'9']+
{ Parser.INTV{i=info lexbuf; v=int_of_string (text lexbuf)} }
| ['0'-'9']+ '.' ['0'-'9']+
{ Parser.FLOATV{i=info lexbuf; v=float_of_string (text lexbuf)} }
| ['A'-'Z' 'a'-'z' '_']
['A'-'Z' 'a'-'z' '_' '0'-'9' '\'']*
{ createID (info lexbuf) (text lexbuf) }
| ":=" | "<:" | "<-" | "->" | "=>" | "==>"
| "{|" | "|}" | "<|" | "|>" | "[|" | "|]" | "=="
{ createID (info lexbuf) (text lexbuf) }
| ['~' '%' '\\' '+' '-' '&' '|' ':' '@' '`' '$']+
{ createID (info lexbuf) (text lexbuf) }
| ['*' '#' '/' '!' '?' '^' '(' ')' '{' '}' '[' ']' '<' '>' '.' ';' '_' ','
'=' '\'']
{ createID (info lexbuf) (text lexbuf) }
| "\"" { resetStr(); startLex := info lexbuf; string lexbuf }
| eof { Parser.EOF(info lexbuf) }
| _ { error (info lexbuf) "Illegal character" }
(* コメント *)
and comment = parse
"/*"
{ depth := succ !depth; comment lexbuf }
| "*/"
{ depth := pred !depth; if !depth > 0 then comment lexbuf }
| eof
{ error (!startLex) "Comment not terminated" }
| [^ '\n']
{ comment lexbuf }
| "\n"
{ newline lexbuf; comment lexbuf }
(* getFile, getName, finishNameでファイル名を取得している *)
and getFile = parse
" "* "\"" { getName lexbuf }
and getName = parse
[^ '"' '\n']+ { filename := (text lexbuf); finishName lexbuf }
and finishName = parse
'"' [^ '\n']* { main lexbuf }
(* 文字列 *)
and string = parse
'"' { Parser.STRINGV {i = !startLex; v=getStr()} }
| '\\' { addStr(escaped lexbuf); string lexbuf }
| '\n' { addStr '\n'; newline lexbuf; string lexbuf }
| eof { error (!startLex) "String not terminated" }
| _ { addStr (Lexing.lexeme_char lexbuf 0); string lexbuf }
(* 文字列のエスケープ文字 *)
and escaped = parse
'n' { '\n' }
| 't' { '\t' }
| '\\' { '\\' }
| '"' { '\034' }
| '\'' { '\'' }
| ['0'-'9']['0'-'9']['0'-'9']
{
let x = int_of_string(text lexbuf) in
if x > 255 then
error (info lexbuf) "Illegal character constant"
else
Char.chr x
}
| [^ '"' '\\' 't' 'n' '\'']
{ error (info lexbuf) "Illegal character constant" }
(* *)
ocamlyaccのファイルは以下のように書かれている。
%{
header
%}
declarations
%%
rules
%%
trailer
parser.mly
にはheader
とtrailer
はなく、declarations
に当たる部分でトークンの宣言がされ、rules
に当たる部分でパースの規則を書いている。字句解析と同様にrules
ではパターンマッチをして、{ }
内に処理を書いています。
/*
* Yacc grammar for the parser. The files parser.mli and parser.ml
* are generated automatically from parser.mly.
*/
%{
open Support.Error
open Support.Pervasive
open Syntax
%}
/* ---------------------------------------------------------------------- */
/* Preliminaries */
/* We first list all the tokens mentioned in the parsing rules
below. The names of the tokens are common to the parser and the
generated lexical analyzer. Each token is annotated with the type
of data that it carries; normally, this is just file information
(which is used by the parser to annotate the abstract syntax trees
that it constructs), but sometimes -- in the case of identifiers and
constant values -- more information is provided.
*/
/* Keyword tokens */
(* トークン *)
%token <Support.Error.info> IMPORT
%token <Support.Error.info> IF
%token <Support.Error.info> THEN
%token <Support.Error.info> ELSE
%token <Support.Error.info> TRUE
%token <Support.Error.info> FALSE
%token <Support.Error.info> SUCC
%token <Support.Error.info> PRED
%token <Support.Error.info> ISZERO
/* Identifier and constant value tokens */
(* 識別子、定数に使う *)
%token <string Support.Error.withinfo> UCID /* uppercase-initial */
%token <string Support.Error.withinfo> LCID /* lowercase/symbolic-initial */
%token <int Support.Error.withinfo> INTV
%token <float Support.Error.withinfo> FLOATV
%token <string Support.Error.withinfo> STRINGV
/* Symbolic tokens */
(* 記号に使う *)
%token <Support.Error.info> APOSTROPHE
%token <Support.Error.info> DQUOTE
%token <Support.Error.info> ARROW
%token <Support.Error.info> BANG
%token <Support.Error.info> BARGT
%token <Support.Error.info> BARRCURLY
%token <Support.Error.info> BARRSQUARE
%token <Support.Error.info> COLON
%token <Support.Error.info> COLONCOLON
%token <Support.Error.info> COLONEQ
%token <Support.Error.info> COLONHASH
%token <Support.Error.info> COMMA
%token <Support.Error.info> DARROW
%token <Support.Error.info> DDARROW
%token <Support.Error.info> DOT
%token <Support.Error.info> EOF
%token <Support.Error.info> EQ
%token <Support.Error.info> EQEQ
%token <Support.Error.info> EXISTS
%token <Support.Error.info> GT
%token <Support.Error.info> HASH
%token <Support.Error.info> LCURLY
%token <Support.Error.info> LCURLYBAR
%token <Support.Error.info> LEFTARROW
%token <Support.Error.info> LPAREN
%token <Support.Error.info> LSQUARE
%token <Support.Error.info> LSQUAREBAR
%token <Support.Error.info> LT
%token <Support.Error.info> RCURLY
%token <Support.Error.info> RPAREN
%token <Support.Error.info> RSQUARE
%token <Support.Error.info> SEMI
%token <Support.Error.info> SLASH
%token <Support.Error.info> STAR
%token <Support.Error.info> TRIANGLE
%token <Support.Error.info> USCORE
%token <Support.Error.info> VBAR
/* ---------------------------------------------------------------------- */
/* The starting production of the generated parser is the syntactic class
toplevel. The type that is returned when a toplevel is recognized is
Syntax.command list.
*/
%start toplevel
%type < Syntax.command list > toplevel
%%
/* ---------------------------------------------------------------------- */
/* Main body of the parser definition */
/* The top level of a file is a sequence of commands, each terminated
by a semicolon. */
(* ここから開始 *)
toplevel :
EOF
{ [] }
| Command SEMI toplevel
{ let cmd = $1 in
let cmds = $3 in
cmd::cmds }
/* A top-level command */
(* インポートもしくは Term を生成 *)
Command :
IMPORT STRINGV { (Import($2.v)) }
| Term
{ (let t = $1 in Eval(tmInfo t,t)) }
(* ATerm もしくは AppTerm を生成 *)
Term :
AppTerm
{ $1 }
| IF Term THEN Term ELSE Term
{ TmIf($1, $2, $4, $6) }
(* ATerm を生成 *)
AppTerm :
ATerm
{ $1 }
| SUCC ATerm
{ TmSucc($1, $2) }
| PRED ATerm
{ TmPred($1, $2) }
| ISZERO ATerm
{ TmIsZero($1, $2) }
/* Atomic terms are ones that never require extra parentheses */
(* 終端 *)
ATerm :
LPAREN Term RPAREN
{ $2 }
| TRUE
{ TmTrue($1) }
| FALSE
{ TmFalse($1) }
| INTV
{ let rec f n = match n with
0 -> TmZero($1.i)
| n -> TmSucc($1.i, f (n-1))
in f $1.v }
/* */
syntax.ml
syntax.mli
これはそのままですね。
(* module Syntax: syntax trees and associated support functions *)
open Support.Pervasive
open Support.Error
(* Data type definitions *)
type term =
| TmTrue of info
| TmFalse of info
| TmIf of info * term * term * term
| TmZero of info
| TmSucc of info * term
| TmPred of info * term
| TmIsZero of info * term
type command = Import of string | Eval of info * term
(* Printing *)
val printtm : term -> unit
val printtm_ATerm : bool -> term -> unit
(* Misc *)
val tmInfo : term -> info
core.ml
core.mli
すべてのterm
は評価するとterm
になるということです。
(* module Core
Core typechecking and evaluation functions
*)
open Syntax
open Support.Error
val eval : term -> term
main.ml
これらを組み合わせてこの処理を実行します。すると本書で触れられている言語が動きます。
(* Module Main: The main program. Deals with processing the command
line, reading files, building and connecting lexers and parsers, etc.
For most experiments with the implementation, it should not be
necessary to change this file.
*)
open Format
open Support.Pervasive
open Support.Error
open Syntax
open Core
let searchpath = ref [ "" ]
let argDefs =
[
( "-I",
Arg.String (fun f -> searchpath := f :: !searchpath),
"Append a directory to the search path" );
]
let parseArgs () =
let inFile = ref (None : string option) in
Arg.parse argDefs
(fun s ->
match !inFile with
| Some _ -> err "You must specify exactly one input file"
| None -> inFile := Some s)
"";
match !inFile with
| None -> err "You must specify an input file"
| Some s -> s
let openfile infile =
let rec trynext l =
match l with
| [] -> err ("Could not find " ^ infile)
| d :: rest -> (
let name = if d = "" then infile else d ^ "/" ^ infile in
try open_in name with Sys_error m -> trynext rest)
in
trynext !searchpath
let parseFile inFile =
let pi = openfile inFile in
let lexbuf = Lexer.create inFile pi in
let result =
try Parser.toplevel Lexer.main lexbuf
with Parsing.Parse_error -> error (Lexer.info lexbuf) "Parse error"
in
Parsing.clear_parser ();
close_in pi;
result
let alreadyImported = ref ([] : string list)
let rec process_file f =
if List.mem f !alreadyImported then ()
else (
alreadyImported := f :: !alreadyImported;
let cmds = parseFile f in
let g c =
open_hvbox 0;
let results = process_command c in
print_flush ();
results
in
List.iter g cmds)
and process_command cmd =
match cmd with
| Import f -> process_file f
| Eval (fi, t) ->
let t' = eval t in
printtm_ATerm true t';
force_newline ();
()
let main () =
let inFile = parseArgs () in
let _ = process_file inFile in
()
let () = set_max_boxes 1000
let () = set_margin 67
let res =
Printexc.catch
(fun () ->
try
main ();
0
with Exit x -> x)
()
let () = print_flush ()
let () = exit res
注意
ちなみに自分の環境だと.mly
ファイルに日本語のコメントを書くとエラーとなるので日本語のコメントはあくまで記事のためという理解でよろしくお願いします。
参考
- https://blog.ojisan.io/tapl-dune/
- https://lms.fun-mooc.fr/c4x/parisdiderot/56002S02/asset/slides_f2ccdfae3814582715015538eda56213.pdf
- https://www.fos.kuis.kyoto-u.ac.jp/~igarashi/class/isle4-06w/text/miniml005.html
- https://discuss.ocaml.org/t/announcing-dune-deps-produces-a-project-centric-dependency-graph/5451
- http://www.fos.kuis.kyoto-u.ac.jp/~igarashi/class/pl/modules.html
- https://ocaml.jp/archive/ocaml-manual-3.06-ja/manual026.html
- https://ocaml.org/manual/lexyacc.html
- https://gkuga.hatenablog.com/entry/2020/03/30/101730
Discussion