Commit b5d247cf authored by POTTIER Francois's avatar POTTIER Francois

Add demos/generate-printers.

parent 4e3f13a9
* avoid exposing Keyword and Stretch in MenhirSdk? what about Positions and IL?
* Document the recent additions (CHANGES + doc).
- attributes in .mly files
rationale / purpose
......@@ -6,6 +8,9 @@
attributes are incompatible with %inline
how attributes are propagated during expansion of parameterized definitions
how %attribute is desugared
- --cmly command line flag
- menhirSdk
- demo of menhirSdk: generate-printers
* move to a new license (GPL V2?), as per Hongbo Zhang's request.
......
......@@ -8,3 +8,4 @@ failures
warnings
*.log
lr.csv
*.cmly
_build
menhir-generate-printers
.PHONY: all test clean
# Find Menhir.
ifndef MENHIR
MENHIR := $(shell ../find-menhir.sh)
endif
OCAMLBUILD := ocamlbuild -use-ocamlfind
MAIN := generate
EXECUTABLE := menhir-generate-printers
all:
$(OCAMLBUILD) $(MAIN).native
rm -f $(MAIN).native
cp -f _build/$(MAIN).native $(EXECUTABLE)
TEST := ../../bench/good/parser_raw
test:
$(MENHIR) --cmly $(TEST).mly
./$(EXECUTABLE) $(TEST).cmly
clean:
rm -f *~ .*~
$(OCAMLBUILD) -clean
true: \
package(unix), \
package(menhirSdk), \
safe_string, \
warn(A)
open Printf
open MenhirSdk
(* ------------------------------------------------------------------------ *)
(* We expect one command line argument: the name of a .cmly file. *)
let filename =
if Array.length Sys.argv = 2
&& Filename.check_suffix Sys.argv.(1) ".cmly" then
Sys.argv.(1)
else begin
eprintf "Usage: %s <parser.cmly>\n" Sys.argv.(0);
exit 1
end
(* ------------------------------------------------------------------------ *)
(* Read this file. This gives rise to a module whose signature is
[Cmly_api.GRAMMAR]. We include it, so we can use it without even
naming it. *)
include Cmly_read.Read (struct
let filename = filename
end)
(* ------------------------------------------------------------------------ *)
(* Auxiliary functions. *)
let newline () =
printf "\n"
let is_attribute name (name', _payload : attribute) =
name = Positions.value name'
let payload (_, payload : attribute) : string =
payload.Stretch.stretch_raw_content
let string_of_type = function
| Stretch.Inferred s -> s
| Stretch.Declared s -> s.Stretch.stretch_raw_content
(* ------------------------------------------------------------------------ *)
(* All names which refer to Menhir's inspection API are qualified with this
module name. *)
let menhir =
"MenhirInterpreter"
(* ------------------------------------------------------------------------ *)
(* The header consists of an [open] directive, followed with content taken
from [@header] attributes. *)
let module_name =
filename
|> Filename.basename
|> Filename.chop_extension
|> String.capitalize_ascii
let header () =
printf "open %s\n" module_name;
List.iter (fun attr ->
if is_attribute "header" attr then
printf "%s\n" (payload attr)
) Grammar.attributes
(* ------------------------------------------------------------------------ *)
(* [name default attrs] returns the payload of an [@name] attribute found in
[attrs], if there is one, and the literal string [default] otherwise. *)
let name default attrs =
try
let attr = List.find (is_attribute "name") attrs in
payload attr
with Not_found ->
sprintf "%S" default
(* [print_symbol()] generates code for a [print_symbol] function, which
converts a symbol to a string. The type of a symbol is [xsymbol];
see the documentation of Menhir's inspection API. *)
let print_symbol () =
printf "let print_symbol = function\n";
Terminal.iter (fun t ->
match Terminal.kind t with
| `REGULAR | `ERROR ->
printf " | %s.X (%s.T %s.T_%s) -> %s\n"
menhir menhir menhir
(Terminal.name t)
(name (Terminal.name t) (Terminal.attributes t))
| `PSEUDO | `EOF ->
()
);
Nonterminal.iter (fun n ->
match Nonterminal.kind n with
| `REGULAR ->
printf " | %s.X (%s.N %s.N_%s) -> %s\n"
menhir menhir menhir
(Nonterminal.name n)
(name (Nonterminal.name n) (Nonterminal.attributes n))
| `START ->
()
)
(* ------------------------------------------------------------------------ *)
(* [printer default attrs] returns the payload of a [@printer] attribute
found in [attrs], within parentheses, if there is one. Otherwise, it
returns a function that ignores its argument and always returns the
literal string [name default attrs]. *)
let printer default attrs =
try
let attr = List.find (is_attribute "printer") attrs in
sprintf "(%s)" (payload attr)
with Not_found ->
sprintf "(fun _ -> %s)" (name default attrs)
(* [print_value()] generates code for a [print_value] function, which
converts a pair of a symbol and its semantic value to a string. The
type of the symbol is ['a symbol], and the type of the value is ['a].
See the documentation of Menhir's inspection API. *)
let print_value () =
printf "let print_value (type a) : a %s.symbol -> a -> string = function\n"
menhir;
Terminal.iter (fun t ->
match Terminal.kind t with
| `REGULAR | `ERROR ->
printf " | %s.T %s.T_%s -> %s\n"
menhir menhir
(Terminal.name t)
(printer (Terminal.name t) (Terminal.attributes t))
| `PSEUDO | `EOF ->
()
);
Nonterminal.iter (fun n ->
match Nonterminal.kind n with
| `REGULAR ->
printf " | %s.N %s.N_%s -> %s\n"
menhir menhir
(Nonterminal.name n)
(printer (Nonterminal.name n) (Nonterminal.attributes n))
| `START ->
()
)
(* [print_token()] generates code for a [print_token] function, which
converts a token to a string. The type of the token is [token].
This is done by converting the token to a pair of a symbol and a value
and invoking [print_value]. *)
let print_token () =
printf "let print_token = function\n";
Terminal.iter (fun t ->
match Terminal.kind t with
| `REGULAR ->
(* Deal with the case where the token carries no semantic value. *)
let pattern, value =
match Terminal.typ t with
| None -> "", "()"
| Some _typ -> " v", "v"
in
printf " | %s%s -> print_value (%s.T %s.T_%s) %s\n"
(Terminal.name t)
pattern
menhir menhir
(Terminal.name t)
value
| `ERROR | `PSEUDO | `EOF ->
()
)
(* ------------------------------------------------------------------------ *)
(* The main program. *)
let () =
header();
newline();
print_symbol();
newline();
print_value();
newline();
print_token()
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment