Previous Up Next
Chapter 7 Extending the syntax of OCaml
7.1 Introduction

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: 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 ();;
7.3 Example: a constant

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
7.5.4 Improvements

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.



Previous Up Next