Commit d237b0e8 authored by POTTIER Francois's avatar POTTIER Francois

New Dune demos.

parent 9c2be923
calc.exe
_build
.merlin
.PHONY: all clean test
DUNE := jbuilder
EXECUTABLE := calc.exe
all:
@ if command -v $(DUNE) > /dev/null ; then \
$(DUNE) build $(EXECUTABLE) ; \
else \
echo "Error: $(DUNE) is required." ; \
fi
clean:
rm -rf `cat .gitignore`
rm -f *~
test: all
@echo "The following command should print 42.0:"
echo "(1 + 2 * 10) * 2" | ./_build/default/$(EXECUTABLE)
This demo is identical to the "calc-param" demo,
but uses dune (a.k.a. jbuilder)
instead of ocamlbuild.
(* Let's do floating-point evaluation, for a change. *)
module FloatSemantics = struct
type number =
float
let inject =
float_of_int
let ( + ) = ( +. )
let ( - ) = ( -. )
let ( * ) = ( *. )
let ( / ) = ( /. )
let (~- ) = (~-. )
end
(* Let us now specialize our parameterized parser. *)
module FloatParser =
Parser.Make(FloatSemantics)
(* The rest is as usual. *)
let process (line : string) =
let linebuf = Lexing.from_string line in
try
(* Run the parser on this line of input. *)
Printf.printf "%f\n%!" (FloatParser.main Lexer.token linebuf)
with
| Lexer.Error msg ->
Printf.fprintf stderr "%s%!" msg
| FloatParser.Error ->
Printf.fprintf stderr "At offset %d: syntax error.\n%!" (Lexing.lexeme_start linebuf)
let process (optional_line : string option) =
match optional_line with
| None ->
()
| Some line ->
process line
let rec repeat channel =
(* Attempt to read one line. *)
let optional_line, continue = Lexer.line channel in
process optional_line;
if continue then
repeat channel
let () =
repeat (Lexing.from_channel stdin)
(jbuild_version 1)
(ocamllex (lexer))
; Compile tokens.mly into a definition of the type [token].
(menhir (
(modules (tokens))
(flags ("--only-tokens"))
))
; Compile parser.mly into a (parameterized) parser.
; We need tokens.mly too, because it contains the token definitions.
; The resulting OCaml files should be named parser.{ml,mli}
; and should *not* contain a definition of the [token] type.
(menhir (
(modules (tokens parser))
(merge_into parser)
(flags ("--external-tokens" "Tokens"))
))
(executable
((name calc))
)
{
open Tokens
exception Error of string
}
(* This rule looks for a single line, terminated with '\n' or eof.
It returns a pair of an optional string (the line that was found)
and a Boolean flag (false if eof was reached). *)
rule line = parse
| ([^'\n']* '\n') as line
(* Normal case: one line, no eof. *)
{ Some line, true }
| eof
(* Normal case: no data, eof. *)
{ None, false }
| ([^'\n']+ as line) eof
(* Special case: some data but missing '\n', then eof.
Consider this as the last line, and add the missing '\n'. *)
{ Some (line ^ "\n"), false }
(* This rule analyzes a single line and turns it into a stream of
tokens. *)
and token = parse
| [' ' '\t']
{ token lexbuf }
| '\n'
{ EOL }
| ['0'-'9']+ as i
{ INT (int_of_string i) }
| '+'
{ PLUS }
| '-'
{ MINUS }
| '*'
{ TIMES }
| '/'
{ DIV }
| '('
{ LPAREN }
| ')'
{ RPAREN }
| _
{ raise (Error (Printf.sprintf "At offset %d: unexpected character.\n" (Lexing.lexeme_start lexbuf))) }
(* These are the functions that we need in order to write our semantic
actions. *)
%parameter<Semantics : sig
type number
val inject: int -> number
val ( + ): number -> number -> number
val ( - ): number -> number -> number
val ( * ): number -> number -> number
val ( / ): number -> number -> number
val ( ~-): number -> number
end>
(* The parser no longer returns an integer; instead, it returns an
abstract number. *)
%start <Semantics.number> main
(* Let us open the [Semantics] module, so as to make all of its
operations available in the semantic actions. *)
%{
open Semantics
%}
%%
main:
| e = expr EOL
{ e }
expr:
| i = INT
{ inject i }
| LPAREN e = expr RPAREN
{ e }
| e1 = expr PLUS e2 = expr
{ e1 + e2 }
| e1 = expr MINUS e2 = expr
{ e1 - e2 }
| e1 = expr TIMES e2 = expr
{ e1 * e2 }
| e1 = expr DIV e2 = expr
{ e1 / e2 }
| MINUS e = expr %prec UMINUS
{ - e }
(* We want the tokens to be independent of the [Semantics] parameter,
so we declare them here, in a separate file, as opposed to within
[parser.mly]. *)
%token <int> INT
%token PLUS MINUS TIMES DIV
%token LPAREN RPAREN
%token EOL
%left PLUS MINUS /* lowest precedence */
%left TIMES DIV /* medium precedence */
%nonassoc UMINUS /* highest precedence */
%%
calc.exe
_build
.merlin
.PHONY: all clean test
DUNE := jbuilder
EXECUTABLE := calc.exe
all:
@ if command -v $(DUNE) > /dev/null ; then \
$(DUNE) build $(EXECUTABLE) ; \
else \
echo "Error: $(DUNE) is required." ; \
fi
clean:
rm -rf `cat .gitignore`
rm -f *~
test: all
@echo "The following command should print 42:"
echo "(1 + 2 * 10) * 2" | ./_build/default/$(EXECUTABLE) --algebraic
@echo "The following command should print 42:"
echo " 1 2 10 * + 2 *" | ./_build/default/$(EXECUTABLE) --reverse
This demo is identical to the "calc-two" demo,
but uses dune (a.k.a. jbuilder)
instead of ocamlbuild.
(* This partial grammar specification defines the syntax of expressions
in algebraic notation. *)
%left PLUS MINUS /* lowest precedence */
%left TIMES DIV /* medium precedence */
%nonassoc UMINUS /* highest precedence */
%%
%public expr:
| i = INT
{ i }
| LPAREN e = expr RPAREN
{ e }
| e1 = expr PLUS e2 = expr
{ e1 + e2 }
| e1 = expr MINUS e2 = expr
{ e1 - e2 }
| e1 = expr TIMES e2 = expr
{ e1 * e2 }
| e1 = expr DIV e2 = expr
{ e1 / e2 }
| MINUS e = expr %prec UMINUS
{ - e }
let algebraic =
ref true
let () =
Arg.parse [
"--algebraic", Arg.Set algebraic, " Use algebraic (that is, infix) notation";
"--reverse", Arg.Clear algebraic, " Use reverse Polish (that is, postfix) notation";
] (fun _ -> ()) (Printf.sprintf "Usage: %s <options>" Sys.argv.(0))
let main =
if !algebraic then
Algebraic.main
else
Reverse.main
let process (line : string) =
let linebuf = Lexing.from_string line in
try
(* Run the parser on this line of input. *)
Printf.printf "%d\n%!" (main Lexer.token linebuf)
with
| Lexer.Error msg ->
Printf.fprintf stderr "%s%!" msg
| Algebraic.Error
| Reverse.Error ->
Printf.fprintf stderr "At offset %d: syntax error.\n%!" (Lexing.lexeme_start linebuf)
let process (optional_line : string option) =
match optional_line with
| None ->
()
| Some line ->
process line
let rec repeat channel =
(* Attempt to read one line. *)
let optional_line, continue = Lexer.line channel in
process optional_line;
if continue then
repeat channel
let () =
repeat (Lexing.from_channel stdin)
(* This partial grammar specification defines the grammar's entry
point to be an expression, followed with an end-of-line token. *)
%start <int> main
%%
main:
| e = expr EOL
{ e }
(jbuild_version 1)
(ocamllex (lexer))
; Compile tokens.mly into a definition of the type [token].
(menhir (
(modules (tokens))
(flags ("--only-tokens"))
))
; Compile reverse.mly into a parser.
(menhir (
(modules (tokens reverse common))
(merge_into reverse)
(flags (
"--external-tokens" "Tokens"
"--unused-token" "LPAREN"
"--unused-token" "RPAREN"
))
))
; Compile algebraic.mly into a parser.
(menhir (
(modules (tokens algebraic common))
(merge_into algebraic)
(flags ("--external-tokens" "Tokens"))
))
(executable
((name calc))
)
{
open Tokens
exception Error of string
}
(* This rule looks for a single line, terminated with '\n' or eof.
It returns a pair of an optional string (the line that was found)
and a Boolean flag (false if eof was reached). *)
rule line = parse
| ([^'\n']* '\n') as line
(* Normal case: one line, no eof. *)
{ Some line, true }
| eof
(* Normal case: no data, eof. *)
{ None, false }
| ([^'\n']+ as line) eof
(* Special case: some data but missing '\n', then eof.
Consider this as the last line, and add the missing '\n'. *)
{ Some (line ^ "\n"), false }
(* This rule analyzes a single line and turns it into a stream of
tokens. *)
and token = parse
| [' ' '\t']
{ token lexbuf }
| '\n'
{ EOL }
| ['0'-'9']+ as i
{ INT (int_of_string i) }
| '+'
{ PLUS }
| '-'
{ MINUS }
| '*'
{ TIMES }
| '/'
{ DIV }
| '('
{ LPAREN }
| ')'
{ RPAREN }
| _
{ raise (Error (Printf.sprintf "At offset %d: unexpected character.\n" (Lexing.lexeme_start lexbuf))) }
(* This partial grammar specification defines the syntax of
expressions in reverse Polish notation. Parentheses are
meaningless, and unary minus is not supported (some other symbol
than MINUS would be required in order to avoid an ambiguity). *)
%%
%public expr:
| i = INT
{ i }
| e1 = expr e2 = expr PLUS
{ e1 + e2 }
| e1 = expr e2 = expr MINUS
{ e1 - e2 }
| e1 = expr e2 = expr TIMES
{ e1 * e2 }
| e1 = expr e2 = expr DIV
{ e1 / e2 }
(* This partial grammar specification defines the set of tokens. *)
%token <int> INT
%token PLUS MINUS TIMES DIV
%token LPAREN RPAREN
%token EOL
%%
.merlin
_build
menhir-generate-printers
.PHONY: all test clean
# The Menhir executable in the PATH and the library MenhirSdk
# should agree on their version number, or this test will fail
# complaining that magic strings do not match.
MENHIR := menhir
DUNE := jbuilder
MAIN := generate
EXECUTABLE := menhir-generate-printers
all:
$(DUNE) build $(MAIN).exe
cp -f _build/default/$(MAIN).exe $(EXECUTABLE)
TEST := ../../test/good/parser_raw
test: all
rm -f $(TEST).cmly
$(MENHIR) --cmly $(TEST).mly
./$(EXECUTABLE) $(TEST).cmly
clean:
rm -f *~ .*~
$(DUNE) clean
rm -f $(EXECUTABLE)
This tool, `menhir-generate-printers`, reads a `.cmly` file and produces code
for three functions, namely `print_symbol`, `print_value`, and `print_token`.
```
val print_symbol: MenhirInterpreter.xsymbol -> string
```
By default, `print_symbol` prints the internal name of a (terminal or
nonterminal) symbol. This can however be changed by attaching a `[@name]`
attribute with this symbol. The attribute payload should be an OCaml
expression of type `string`.
```
val print_value: 'a MenhirInterpreter.symbol -> 'a -> string
val print_token: token -> string
```
By default, `print_value` and `print_token` ignore the semantic value and
print just the name of the symbol, like `print_symbol`. This can however be
changed by attaching a `[@printer]` attribute with this symbol. The attribute
payload should be an OCaml expression of type `_ -> string`, where `_` stands
for an appropriate type of semantic values.
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)
(* ------------------------------------------------------------------------ *)
(* All names which refer to Menhir's inspection API are qualified with this
module name. We do not [open] this module because that might hide some
names exploited by the user within attributes. *)
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\n" module_name;
List.iter (fun attr ->
if Attribute.has_label "header" attr then
printf "%s\n" (Attribute.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 (Attribute.has_label "name") attrs in
Attribute.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 ->
()
);
printf "\n"
(* ------------------------------------------------------------------------ *)
(* [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