Syntax extensions in OCaml can be done by extending the
grammars entries of the OCaml syntax. All grammars entries are defined
in the module named Pcaml. They all return values of types
defined in the module MLast: nodes of these types can be
created using the predefined quotation expansion q_MLast.cmo.
The entries in Pcaml are:
expr for expressions, returning values of type
MLast.expr.
patt for patterns, returning values of type
MLast.patt.
ctyp for types, returning values of type
MLast.ctyp.
module_type for module types, returning values of type
MLast.module_type.
module_expr for module expressions, returning values of type
MLast.module_expr.
sig_item for signature items, returning values of type
MLast.sig_item.
str_item for structure items, returning values of type
MLast.str_item.
Most of these entries are generally defined (``extended'') with
several ``levels'' (see chapter 3). Some of them
are labelled, in order to be able to extend them or to insert other
levels.
The levels and their possible labels are not predefined. It depend on
how the syntax define them. To see which labels are defined and which
rule they contain, enter the toplevel and type for the normal syntax:
#load "camlp4o.cma";;
Grammar.Entry.print Pcaml.expr;; (* for the expressions *)
Grammar.Entry.print Pcaml.patt;; (* for the patterns *)
(* ... and so on *)
For the revised syntax, load "camlp4r.cma" instead. If you
defined another syntax of the whole language or want to see the other
syntaxes provided, load it before, and call Grammar.Entry.print
of the desired grammar entry. Look at the manual page
(man camlp4 in the shell) to see all available syntaxes and
extensions.
Once you have the list of the grammar entry you want to extend and the
possible level label, you can do your extension.
| 7.2 |
Example: ``repeat until'' like in Pascal |
|
If you read all this tutorial, you are able to understand this
complete example. If you did not, just create the files and type the
indicated commands.
Write first a file named foo.ml containing:
open Pcaml;;
EXTEND
expr: LEVEL "expr1"
[[ "repeat"; e1 = expr; "until"; e2 = expr ->
<:expr< do { $e1$; while not $e2$ do { $e1$; } } >> ]];
END;;
The compilation of this file can be done by typing under the shell
(the dollar is the shell prompt):
$ ocamlc -pp "camlp4o pa_extend.cmo q_MLast.cmo" -I +camlp4 \
-c foo.ml
Here is the file bar.ml containing a repeat..until statement:
let main () =
let i = ref 0 in
repeat print_int !i; incr i until !i = 10;
print_newline ()
let _ = main ()
You can compile it by typing:
$ ocamlc -pp "camlp4o ./foo.cmo" bar.ml
And run it:
$ ./a.out
0123456789
Or just pretty print the program with the expanded syntax:
$ camlp4o ./foo.cmo pr_o.cmo bar.ml
let main () =
let i = ref 0 in
begin
begin print_int !i; incr i end;
while not (!i = 10) do print_int !i; incr i done;
end;
print_newline ()
;;
main ();;
If you want to have the equivalent of a #define of C, you can
write for example, if you want FOO to be replaced by 54
in expressions and patterns:
open Pcaml;;
EXTEND
expr: LEVEL "simple"
[[ UIDENT "FOO" -> <:expr< 54 >> ]];
patt: LEVEL "simple"
[[ UIDENT "FOO" -> <:patt< 54 >> ]];
END;;
The compilation of this file can be done by typing:
$ ocamlc -pp "camlp4o pa_extend.cmo q_MLast.cmo" -I +camlp4 \
-c foo.ml
Here is the file bar.ml containing FOO constants:
FOO;;
function FOO -> 22;;
You can compile it by typing:
$ ocamlc -pp "camlp4o ./foo.cmo" bar.ml
You can just pretty print the program with the expanded syntax:
$ camlp4o ./foo.cmo pr_o.cmo bar.ml
54;;
function 54 -> 22;;
| 7.4 |
Example: a ``for'' loop like in C |
|
Here is an example of an syntax extension allowing to write a ``for''
loop like in C. A construction is added with the loop variable and 3
parameters, simple expressions: the first one is the initial value,
the second the test, the third the way to change the loop variable.
Note that we use here the directives #load inside the source of
the syntax extension, allowing to parse it with camlp4o without
having to specify these files in the command line.
File ``cloop.ml'':
#load "q_MLast.cmo";;
#load "pa_extend.cmo";;
open Pcaml
let gensym =
let cnt = ref 0 in
fun var ->
let x = incr cnt; !cnt in
var ^ "_gensym" ^ string_of_int x
let gen_for loc v iv wh nx e =
let loop_fun = gensym "iter" in
<:expr<
let rec $lid:loop_fun$ $lid:v$ =
if $wh$ then do { $e$; $lid:loop_fun$ $nx$ } else ()
in
$lid:loop_fun$ $iv$ >>
EXTEND
expr: LEVEL "expr1"
[ [ "for"; v = LIDENT; iv = expr LEVEL "simple";
wh = expr LEVEL "simple"; nx = expr LEVEL "simple";
"do"; e = expr; "done" ->
gen_for loc v iv wh nx e ] ]
;
END
Compile this file with:
$ ocamlc -pp camlp4o -I +camlp4 -c cloop.ml
Example under the toplevel:
$ ocaml
Objective Caml version 3.02+7 (2001-09-29)
# #load "camlp4o.cma";;
Camlp4 Parsing version 3.02+7 (2001-09-29)
# #load "cloop.cmo";;
# for i = 0 to 10 do print_int i; done;; (* normal loop *)
012345678910- : unit = ()
# for c 0 (c<10) (c+1) do print_int c; done;;
0123456789- : unit = ()
# for c 0 (c<10) (c+3) do print_int c; done;;
0369- : unit = ()
Exemple of compilation of a program using this construction:
$ cat foo.ml
for c 0 (c<10) (c+2) do print_int c; done
$ ocamlc -pp "camlp4o ./cloop.cmo" -c foo.ml
And if you want to see the generated program (for example to check
that the extension is correct):
$ camlp4o ./cloop.cmo pr_o.cmo foo.ml
let rec iter_gensym1 c =
if c < 10 then begin print_int c; iter_gensym1 (c + 2) end
in
iter_gensym1 0;;
| 7.5 |
Example: generating printers of types |
|
We are going to define a syntax extension, so that for all types
definitions, the definition of printers of the values of this types
is automatically added. In this example, we limit to sum types (types
with constructors), but it can be easily extensible for record types,
abstract types, types renaming.
| 7.5.1 |
First version: monomorphic sum types with constant constructors |
|
The example, which is going to be our test, is the following file
``col.ml'':
type colour = Red | Green | Blue
We want that, when preprocessed with the correct syntax extension,
this file be interpreted like this:
type colour = Red | Green | Blue
let print_colour =
function
Red -> print_string "Red"
| Green -> print_string "Green"
| Blue -> print_string "Blue"
The syntax extension will be defined in the following file
``pa_type.ml''. As a beginning, let us just see how we insert
the grammar rule. The function ``gen_print_funs'' generating
the printer functions just generates a phony statement:
#load "pa_extend.cmo";;
#load "q_MLast.cmo";;
let gen_print_funs loc tdl =
<:str_item< not yet implemented >>
let _ =
EXTEND
Pcaml.str_item:
[ [ "type"; tdl = LIST1 Pcaml.type_declaration SEP "and" ->
let si1 = <:str_item< type $list:tdl$ >> in
let si2 = gen_print_funs loc tdl in
<:str_item< declare $si1$; $si2$; end >> ] ]
;
END
Remark the ``declare'' statement in the ``str_item''
syntax tree at the end of this file, destinated to group two structure
items together: 1/ the type definition 2/ the printer.
This file can be compiled like this:
$ ocamlc -pp camlp4o -I +camlp4 -c pa_type.ml
We can test the example file, ``col.ml'', but not yet with the
compiler, since it would generate semantic error because of the ``not
yet implemented'' statement. Let us test it therefore with a pretty
printer:
$ camlp4o ./pa_type.cmo pr_o.cmo col.ml
<W> Grammar extension: in [str_item], some rule has been masked
type colour =
Red
| Green
| Blue
let _ = not yet implemented
See the extra generated statement ``not yet implemented''. You remark,
also, that there is a warning in the beginning: it means that the
syntax rule we added in str_item was already present in the
grammar we used.
To avoid such a warning message, the solution is to add, before the
EXTEND statement, a DELETE_RULE statement:
DELETE_RULE
Pcaml.str_item: "type"; LIST1 Pcaml.type_declaration SEP "and"
END;
Let us attack now the function gen_print_funcs. It receives a
list (since the ``type'' declaration can define several types,
possibly mutually recursive) of types definitions. We know that we
have to generate a definition, recursive, with as many printing
functions as types. The following function,
gen_one_type_print_fun, will generate the printer for one type
definition. For the moment, the body is a ``not yet implemented''
statement:
let fun_name n = "print_" ^ n
let gen_one_print_fun loc ((loc, n), tpl, tk, cl) =
<:patt< $lid:fun_name n$ >>, <:expr< not yet implemented >>
let gen_print_funs loc tdl =
let pel = List.map (gen_one_print_fun loc) tdl in
<:str_item< value rec $list:pel$ >>
Recompile the syntax expander file with these functions and test with
``col.ml'': you can see a function named ``print_colour''.
Let use improve now ``gen_one_print_fun''. It has to generate a
let binding definition, composed of the couple of a pattern (the name
of the function) and an expression. Our function receives as parameter
a type definition which is a t-uple of 4 values: 1/ the type name
(with his location), 2/ the list of its possible parameters, 3/ the
type kind (a type, actually) and 4/ a list of possible constraints.
In a first version, we are going to ignore the type parameters
``tpl'': we see later how they intervene in the generated
function and our code will work, for the moment, only for monomorphic
types.
We limit also to the ``sum'' types (i.e. types with constructors); for
other types kinds, we shall generate a function which fails.
We added the function ``gen_print_sum'' which treats a sum type
by generating a match association for each constructor (function
``gen_print_cons'') and building the function with the
resulting list.
That function ``gen_print_cons'' gets a constructor definition,
i.e. a tuple with: 1/ a location, 2/ a string (the constructor name)
and 3/ a list of types parameters (ctyp list). We ignore for the
moments the constructors parameters. The function
``gen_print_cons_patt'' generates the pattern part of the case,
and ``gen_print_cons_expr'' the expression part of the
function, the print statement:
Here is a first (but complete) version of our syntax extension (file
``pa_type.ml''):
#load "pa_extend.cmo";;
#load "q_MLast.cmo";;
let fun_name n = "print_" ^ n
let gen_print_cons_patt loc c tl =
<:patt< $uid:c$ >>
let gen_print_cons_expr loc c tl =
<:expr< print_string $str:c$ >>
let gen_print_cons (loc, c, tl) =
let p = gen_print_cons_patt loc c tl in
let e = gen_print_cons_expr loc c tl in
p, None, e
let gen_print_sum loc cdl =
let pwel = List.map gen_print_cons cdl in
<:expr< fun [ $list:pwel$ ] >>
let gen_one_print_fun loc ((loc, n), tpl, tk, cl) =
let body =
match tk with
<:ctyp< [ $list:cdl$ ] >> -> gen_print_sum loc cdl
| _ -> <:expr< fun _ -> failwith $str:fun_name n$ >>
in
<:patt< $lid:fun_name n$ >>, body
let gen_print_funs loc tdl =
let pel = List.map (gen_one_print_fun loc) tdl in
<:str_item< value rec $list:pel$ >>
let _ =
DELETE_RULE
Pcaml.str_item: "type"; LIST1 Pcaml.type_declaration SEP "and"
END;
EXTEND
Pcaml.str_item:
[ [ "type"; tdl = LIST1 Pcaml.type_declaration SEP "and" ->
let si1 = <:str_item< type $list:tdl$ >> in
let si2 = gen_print_funs loc tdl in
<:str_item< declare $si1$; $si2$; end >> ] ]
;
END
We can recompile this version, and test on the example file
``col.ml'' by pretty printing the result:
$ ocamlc -pp camlp4o -I +camlp4 -c pa_type.ml
$ camlp4o ./pa_type.cmo pr_o.cmo col.ml
type colour =
Red
| Green
| Blue
let rec print_colour =
function
Red -> print_string "Red"
| Green -> print_string "Green"
| Blue -> print_string "Blue"
It is what we wanted! This can be used, now, directly with the
compiler without the pretty printing phase:
$ ocamlc -pp "camlp4o ./pa_type.cmo" -c col.ml
We could also add the directive ``#load "./pa_type.cmo";;'' in
the beginning of ``col.ml'' and just compile with:
$ ocamlc -pp camlp4o -c col.ml
but it is not a good idea, since we may want to use the same source
with the preprocessing or without it.
| 7.5.2 |
Second version: constructors with parameters |
|
Let us add the case of sum types having constructors with
parameters. Our example for testing that will be the definition of
lambda terms of section 4.7. File ``term.ml'':
type term =
Var of string
| Func of string * term
| Appl of term * term
The desired result should be something like this:
type term =
Var of string
| Func of string * term
| Appl of term * term
let rec print_term =
function
Var x1 ->
print_string "Var"; print_string " ("; print_string x1;
print_string ")"
| Func (x1, x2) ->
print_string "Func"; print_string " ("; print_string x1
print_string ", "; print_term x2; print_string ")"
| Appl (x1, x2) ->
print_string "Appl"; print_string " ("; print_term x1
print_string ", "; print_term x2; print_string ")"
Like in the above desired result, we decide to name the parameters
with ``x'' followed by the number of the parameter, defined by
the following function ``param_name'':
let param_name cnt = "x" ^ string_of_int cnt
We need a function ``list_mapi'', which is like
``List.map'' but the function applied receives the number of
the list element as first parameter. This allows us to generate the
name of the constructor parameter while exploring the type list:
let list_mapi f l =
let rec loop cnt =
function
x :: l -> f cnt x :: loop (cnt + 1) l
| [] -> []
in
loop 1 l
The function ``gen_print_cons_patt'' which treats the pattern
part of the match association, is changed like this:
let gen_print_cons_patt loc c tl =
let pl =
list_mapi (fun n _ -> <:patt< $lid:param_name n$ >>)
tl
in
List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>)
<:patt< $uid:c$ >> pl
With these changes, the pattern part of the generated function
``print_term'' is correct. Test it.
For the expression part, we have to generate the call to the printers
for all the constructors parameters. We add a function
``gen_print_type'' to generate a printer associated with a
type. For the moment, it just generates it for a simple type name. For
other types, it generates a printer displaying an ellipsis:
let gen_print_type loc =
function
<:ctyp< $lid:s$ >> -> <:expr< $lid:fun_name s$ >>
| _ -> <:expr< fun _ -> print_string "..." >>
We need also a function which generates the call to this printer
function with the constructor parameter:
let gen_call loc n f = <:expr< $f$ $lid:param_name n$ >>
and a function adding the extra syntax: spaces, parentheses and
commas:
let gen_print_con_extra_syntax loc el =
let rec loop =
function
[] | [_] as e -> e
| e :: el -> e :: <:expr< print_string ", " >> :: loop el
in
<:expr< print_string " (" >> :: loop el @
[<:expr< print_string ")" >>]
Now, we can change the function ``gen_print_cons_expr'' using
all these functions:
let gen_print_cons_expr loc c tl =
let pr_con = <:expr< print_string $str:c$ >> in
match tl with
[] -> pr_con
| _ ->
let pr_params =
let type_funs = List.map (gen_print_type loc) tl in
list_mapi (gen_call loc) type_funs
in
let pr_all = gen_print_con_extra_syntax loc pr_params in
let el = pr_con :: pr_all in
<:expr< do { $list:el$ } >>
Grouping all these functions together, you can make a second version
of ``pa_type.ml'' which works with the file ``term.ml''.
Test it! Try it also with your own programs having sum type definitions.
| 7.5.3 |
Third version: polymorphic types |
|
This time, we are going to generate the good code for polymorphic
types, i.e. types defined with types variables. Our example will be
the definition of the type ``mlist'' like this. File
``mlist.ml'':
type 'a mlist = Nil | Cons of 'a * 'a mlist
The printer of such a type will receive as parameter the print
functions of the instantiated type. As many as the type has type
variables. We can then call ``print_mlist
print_int'' for an ``int mlist'', ``print_mlist
print_string'' for a ``string mlist'' and so on.
The desired result for the type ``mlist'' is:
type 'a mlist = Nil | Cons of 'a * 'a mlist
let rec print_mlist pr_a =
function
Nil -> print_string "Nil"
| Cons (x1, x2) ->
print_string "Cons"; print_string " ("; pr_a x1;
print_string ", "; print_mlist pr_a x2; print_string ")"
The name of the printer function for a type variable will be
``pr_'' followed by the type variable name:
let fun_param_name n = "pr_" ^ n
To add the function parameters to the printer definition (``let
print_mlist pr_a = ...'' in our example), we
change our function ``gen_one_print_func'' by inserting them in
the body of the function, just before its result, like this:
let body =
List.fold_right
(fun (v, _) e ->
<:expr< fun $lid:fun_param_name v$ -> $e$ >>)
tpl body
in
For the printing of a type variable (``pr_a x1'' in our
example), we add the case of type variables in our function
``gen_print_type'':
| <:ctyp< '$s$ >> -> <:expr< $lid:fun_param_name s$ >>
And to generate the printing of types with parameters (we have a
recursive case in our example: ``print_mlist pr_a
x2'' for the constructor parameter of type ``'a
mlist''), we add, in the same function, the case of types
applications. But since it needs a recursive call, the function
``gen_print_type'' is rewritten with a internal recursive
definition.
Here is the complete version:
#load "pa_extend.cmo";;
#load "q_MLast.cmo";;
let fun_name n = "print_" ^ n
let fun_param_name n = "pr_" ^ n
let param_name cnt = "x" ^ string_of_int cnt
let list_mapi f l =
let rec loop cnt =
function
x :: l -> f cnt x :: loop (cnt + 1) l
| [] -> []
in
loop 1 l
let gen_print_type loc t =
let rec eot =
function
<:ctyp< $t1$ $t2$ >> -> <:expr< $eot t1$ $eot t2$ >>
| <:ctyp< $lid:s$ >> -> <:expr< $lid:fun_name s$ >>
| <:ctyp< '$s$ >> -> <:expr< $lid:fun_param_name s$ >>
| _ -> <:expr< fun _ -> print_string "..." >>
in
eot t
let gen_call loc n f = <:expr< $f$ $lid:param_name n$ >>
let gen_print_cons_patt loc c tl =
let pl =
list_mapi (fun n _ -> <:patt< $lid:param_name n$ >>)
tl
in
List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>)
<:patt< $uid:c$ >> pl
let gen_print_con_extra_syntax loc el =
let rec loop =
function
[] | [_] as e -> e
| e :: el -> e :: <:expr< print_string ", " >> :: loop el
in
<:expr< print_string " (" >> :: loop el @
[<:expr< print_string ")" >>]
let gen_print_cons_expr loc c tl =
let pr_con = <:expr< print_string $str:c$ >> in
match tl with
[] -> pr_con
| _ ->
let pr_params =
let type_funs = List.map (gen_print_type loc) tl in
list_mapi (gen_call loc) type_funs
in
let pr_all = gen_print_con_extra_syntax loc pr_params in
let el = pr_con :: pr_all in
<:expr< do { $list:el$ } >>
let gen_print_cons (loc, c, tl) =
let p = gen_print_cons_patt loc c tl in
let e = gen_print_cons_expr loc c tl in
p, None, e
let gen_print_sum loc cdl =
let pwel = List.map gen_print_cons cdl in
<:expr< fun [ $list:pwel$ ] >>
let gen_one_print_fun loc ((loc, n), tpl, tk, cl) =
let body =
match tk with
<:ctyp< [ $list:cdl$ ] >> -> gen_print_sum loc cdl
| _ -> <:expr< fun _ -> failwith $str:fun_name n$ >>
in
let body =
List.fold_right
(fun (v, _) e ->
<:expr< fun $lid:fun_param_name v$ -> $e$ >>)
tpl body
in
<:patt< $lid:fun_name n$ >>, body
let gen_print_funs loc tdl =
let pel = List.map (gen_one_print_fun loc) tdl in
<:str_item< value rec $list:pel$ >>
let _ =
DELETE_RULE
Pcaml.str_item: "type"; LIST1 Pcaml.type_declaration SEP "and"
END;
EXTEND
Pcaml.str_item:
[ [ "type"; tdl = LIST1 Pcaml.type_declaration SEP "and" ->
let si1 = <:str_item< type $list:tdl$ >> in
let si2 = gen_print_funs loc tdl in
<:str_item< declare $si1$; $si2$; end >> ] ]
;
END
It is possible to add, the same way, the other kind of types: record
types, abstract types, and so on.
Another interesting improvement is to generate, instead of
``print_string'' statements, functions of the
``Format'' library, with pretty printing boxes.
Further, that version can be still improved, by generating only one
``Format.fprintf'' by printing case (instead of a sequence of
printing statements), using the very useful abbreviations provided by
that library by the prefixes ``@'' inside the format strings.