File: tutorial007.html

package info (click to toggle)
ocaml-doc 3.09-1
links: PTS
area: non-free
in suites: etch, etch-m68k
size: 10,428 kB
ctags: 4,963
sloc: ml: 9,244; makefile: 2,413; ansic: 122; sh: 49; asm: 17
file content (807 lines) | stat: -rw-r--r-- 30,109 bytes
parent folder | download | duplicates (2)
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN"
            "http://www.w3.org/TR/REC-html40/loose.dtd">
<HTML>
<HEAD>

<META http-equiv="Content-Type" content="text/html; charset=ISO-8859-1">
<META name="GENERATOR" content="hevea 1.06">
<TITLE>
 Extending the syntax of OCaml
</TITLE>
</HEAD>
<BODY TEXT=black BGCOLOR=white>
<A HREF="tutorial006.html"><IMG SRC ="previous_motif.gif" ALT="Previous"></A>
<A HREF="index.html"><IMG SRC ="contents_motif.gif" ALT="Up"></A>
<A HREF="tutorial008.html"><IMG SRC ="next_motif.gif" ALT="Next"></A>
<HR>
<TABLE CELLPADDING=0 CELLSPACING=0 WIDTH="100%">
<TR><TD BGCOLOR="#2de52d"><DIV ALIGN=center><TABLE>
<TR><TD><A NAME="htoc56"><B><FONT SIZE=6>Chapter&nbsp;7</FONT></B></A></TD>
<TD WIDTH="100%" ALIGN=center><B><FONT SIZE=6>Extending the syntax of OCaml</FONT></B></TD>
</TR></TABLE></DIV></TD>
</TR></TABLE>
<A NAME="c:tutext"></A>
<A NAME="toc48"></A><TABLE CELLPADDING=0 CELLSPACING=0 WIDTH="100%">
<TR><TD BGCOLOR="#66ff66"><DIV ALIGN=center><TABLE>
<TR><TD><A NAME="htoc57"><B><FONT SIZE=5>7.1</FONT></B></A></TD>
<TD WIDTH="100%" ALIGN=center><B><FONT SIZE=5>Introduction</FONT></B></TD>
</TR></TABLE></DIV></TD>
</TR></TABLE><BR>
Syntax extensions in <CODE>OCaml</CODE> can be done by extending the
grammars entries of the OCaml syntax. All grammars entries are defined
in the module named <CODE>Pcaml</CODE>. They all return values of types
defined in the module <CODE>MLast</CODE>: nodes of these types can be
created using the predefined quotation expansion <CODE>q_MLast.cmo</CODE>.<BR>
<BR>


The entries in <CODE>Pcaml</CODE> are:
<UL><LI><CODE>expr</CODE> for expressions, returning values of type
<CODE>MLast.expr</CODE>.<BR>
<BR>
<LI><CODE>patt</CODE> for patterns, returning values of type
<CODE>MLast.patt</CODE>.<BR>
<BR>
<LI><CODE>ctyp</CODE> for types, returning values of type
<CODE>MLast.ctyp</CODE>.<BR>
<BR>
<LI><CODE>module_type</CODE> for module types, returning values of type
<CODE>MLast.module_type</CODE>.<BR>
<BR>
<LI><CODE>module_expr</CODE> for module expressions, returning values of type
<CODE>MLast.module_expr</CODE>.<BR>
<BR>
<LI><CODE>sig_item</CODE> for signature items, returning values of type
<CODE>MLast.sig_item</CODE>.<BR>
<BR>
<LI><CODE>str_item</CODE> for structure items, returning values of type
<CODE>MLast.str_item</CODE>.</UL>
Most of these entries are generally defined (``extended'') with
several ``levels'' (see chapter <A HREF="tutorial003.html#c:tutgram">3</A>). Some of them
are labelled, in order to be able to extend them or to insert other
levels.<BR>
<BR>


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:
<PRE>
       #load "camlp4o.cma";;
       Grammar.Entry.print Pcaml.expr;; (* for the expressions *)
       Grammar.Entry.print Pcaml.patt;; (* for the patterns *)
                                        (* ... and so on *)
</PRE>
For the revised syntax, load <CODE>"camlp4r.cma"</CODE> instead. If you
defined another syntax of the whole language or want to see the other
syntaxes provided, load it before, and call <CODE>Grammar.Entry.print</CODE>
of the desired grammar entry. Look at the manual page
(<CODE>man camlp4</CODE> in the shell) to see all available syntaxes and
extensions.<BR>
<BR>


Once you have the list of the grammar entry you want to extend and the
possible level label, you can do your extension.<BR>
<BR>


<A NAME="toc49"></A><TABLE CELLPADDING=0 CELLSPACING=0 WIDTH="100%">
<TR><TD BGCOLOR="#66ff66"><DIV ALIGN=center><TABLE>
<TR><TD><A NAME="htoc58"><B><FONT SIZE=5>7.2</FONT></B></A></TD>
<TD WIDTH="100%" ALIGN=center><B><FONT SIZE=5>Example: ``repeat until'' like in Pascal</FONT></B></TD>
</TR></TABLE></DIV></TD>
</TR></TABLE><BR>
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.<BR>
<BR>


Write first a file named <CODE>foo.ml</CODE> containing:
<PRE>
       open Pcaml;;
       EXTEND
         expr: LEVEL "expr1"
           [[ "repeat"; e1 = expr; "until"; e2 = expr -&gt;
                 &lt;:expr&lt; do { $e1$; while not $e2$ do { $e1$; } } &gt;&gt; ]];
       END;;
</PRE>
The compilation of this file can be done by typing under the shell
(the dollar is the shell prompt):
<PRE>
       $ ocamlc -pp "camlp4o pa_extend.cmo q_MLast.cmo" -I +camlp4 \
           -c foo.ml
</PRE>
Here is the file <CODE>bar.ml</CODE> containing a <CODE>repeat..until</CODE> statement:
<PRE>
       let main () =
         let i = ref 0 in
         repeat print_int !i; incr i until !i = 10;
         print_newline ()
       let _ = main ()
</PRE>
You can compile it by typing:
<PRE>
       $ ocamlc -pp "camlp4o ./foo.cmo" bar.ml
</PRE>
And run it:
<PRE>
       $ ./a.out
       0123456789
</PRE>
Or just pretty print the program with the expanded syntax:
<PRE>
       $ 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 ();;
</PRE>
<A NAME="toc50"></A><TABLE CELLPADDING=0 CELLSPACING=0 WIDTH="100%">
<TR><TD BGCOLOR="#66ff66"><DIV ALIGN=center><TABLE>
<TR><TD><A NAME="htoc59"><B><FONT SIZE=5>7.3</FONT></B></A></TD>
<TD WIDTH="100%" ALIGN=center><B><FONT SIZE=5>Example: a constant</FONT></B></TD>
</TR></TABLE></DIV></TD>
</TR></TABLE><BR>
If you want to have the equivalent of a <CODE>#define</CODE> of C, you can
write for example, if you want <CODE>FOO</CODE> to be replaced by <CODE>54</CODE>
in expressions and patterns:
<PRE>
       open Pcaml;;
       EXTEND
         expr: LEVEL "simple"
           [[ UIDENT "FOO" -&gt; &lt;:expr&lt; 54 &gt;&gt; ]];
         patt: LEVEL "simple"
           [[ UIDENT "FOO" -&gt; &lt;:patt&lt; 54 &gt;&gt; ]];
       END;;
</PRE>
The compilation of this file can be done by typing:
<PRE>
       $ ocamlc -pp "camlp4o pa_extend.cmo q_MLast.cmo" -I +camlp4 \
           -c foo.ml
</PRE>
Here is the file <CODE>bar.ml</CODE> containing <CODE>FOO</CODE> constants:
<PRE>
       FOO;;
       function FOO -&gt; 22;;
</PRE>
You can compile it by typing:
<PRE>
       $ ocamlc -pp "camlp4o ./foo.cmo" bar.ml
</PRE>
You can just pretty print the program with the expanded syntax:
<PRE>
       $ camlp4o ./foo.cmo pr_o.cmo bar.ml
       54;;
       function 54 -&gt; 22;;
</PRE>
<A NAME="toc51"></A><TABLE CELLPADDING=0 CELLSPACING=0 WIDTH="100%">
<TR><TD BGCOLOR="#66ff66"><DIV ALIGN=center><TABLE>
<TR><TD><A NAME="htoc60"><B><FONT SIZE=5>7.4</FONT></B></A></TD>
<TD WIDTH="100%" ALIGN=center><B><FONT SIZE=5>Example: a ``for'' loop like in C</FONT></B></TD>
</TR></TABLE></DIV></TD>
</TR></TABLE><BR>
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.<BR>
<BR>


Note that we use here the directives <CODE>#load</CODE> inside the source of
the syntax extension, allowing to parse it with <CODE>camlp4o</CODE> without
having to specify these files in the command line.<BR>
<BR>


File ``cloop.ml'':
<PRE>
       #load "q_MLast.cmo";;
       #load "pa_extend.cmo";;
       
       open Pcaml
       
       let gensym =
         let cnt = ref 0 in
         fun var -&gt;
           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
         &lt;:expr&lt;
           let rec $lid:loop_fun$ $lid:v$ =
             if $wh$ then do { $e$; $lid:loop_fun$ $nx$ } else ()
           in
           $lid:loop_fun$ $iv$ &gt;&gt;
       
       EXTEND
         expr: LEVEL "expr1"
           [ [ "for"; v = LIDENT; iv = expr LEVEL "simple";
               wh = expr LEVEL "simple"; nx = expr LEVEL "simple";
               "do"; e = expr; "done" -&gt;
                 gen_for loc v iv wh nx e ] ]
         ;
       END
</PRE>
Compile this file with:
<PRE>
       $ ocamlc -pp camlp4o -I +camlp4 -c cloop.ml
</PRE>
Example under the toplevel:
<PRE>
       $ 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&lt;10) (c+1) do print_int c; done;;
       0123456789- : unit = ()
       # for c 0 (c&lt;10) (c+3) do print_int c; done;;
       0369- : unit = ()
</PRE>
Exemple of compilation of a program using this construction:
<PRE>
       $ cat foo.ml
       for c 0 (c&lt;10) (c+2) do print_int c; done
       $ ocamlc -pp "camlp4o ./cloop.cmo" -c foo.ml
</PRE>
And if you want to see the generated program (for example to check
that the extension is correct):
<PRE>
       $ camlp4o ./cloop.cmo pr_o.cmo foo.ml
       let rec iter_gensym1 c =
         if c &lt; 10 then begin print_int c; iter_gensym1 (c + 2) end
       in
       iter_gensym1 0;;
</PRE>
<A NAME="toc52"></A><TABLE CELLPADDING=0 CELLSPACING=0 WIDTH="100%">
<TR><TD BGCOLOR="#66ff66"><DIV ALIGN=center><TABLE>
<TR><TD><A NAME="htoc61"><B><FONT SIZE=5>7.5</FONT></B></A></TD>
<TD WIDTH="100%" ALIGN=center><B><FONT SIZE=5>Example: generating printers of types</FONT></B></TD>
</TR></TABLE></DIV></TD>
</TR></TABLE><BR>
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.<BR>
<BR>
<TABLE CELLPADDING=0 CELLSPACING=0 WIDTH="100%">
<TR><TD BGCOLOR="#7fff7f"><DIV ALIGN=center><TABLE>
<TR><TD><A NAME="htoc62"><B><FONT SIZE=4>7.5.1</FONT></B></A></TD>
<TD WIDTH="100%" ALIGN=center><B><FONT SIZE=4>First version: monomorphic sum types with constant constructors</FONT></B></TD>
</TR></TABLE></DIV></TD>
</TR></TABLE><BR>
The example, which is going to be our test, is the following file
``<CODE>col.ml</CODE>'':
<PRE>
       type colour = Red | Green | Blue
</PRE>
We want that, when preprocessed with the correct syntax extension,
this file be interpreted like this:
<PRE>
       type colour = Red | Green | Blue
       let print_colour =
         function
           Red -&gt; print_string "Red"
         | Green -&gt; print_string "Green"
         | Blue -&gt; print_string "Blue"
</PRE>
The syntax extension will be defined in the following file
``<CODE>pa_type.ml</CODE>''. As a beginning, let us just see how we insert
the grammar rule. The function ``<CODE>gen_print_funs</CODE>'' generating
the printer functions just generates a phony statement:
<PRE>
       #load "pa_extend.cmo";;
       #load "q_MLast.cmo";;

       let gen_print_funs loc tdl =
         &lt;:str_item&lt; not yet implemented &gt;&gt;
       
       let _ =
         EXTEND
           Pcaml.str_item:
             [ [ "type"; tdl = LIST1 Pcaml.type_declaration SEP "and" -&gt;
                   let si1 = &lt;:str_item&lt; type $list:tdl$ &gt;&gt; in
                   let si2 = gen_print_funs loc tdl in
                   &lt;:str_item&lt; declare $si1$; $si2$; end &gt;&gt; ] ]
           ;
         END
</PRE>
Remark the ``<CODE>declare</CODE>'' statement in the ``<CODE>str_item</CODE>''
syntax tree at the end of this file, destinated to group two structure
items together: 1/ the type definition 2/ the printer.<BR>
<BR>


This file can be compiled like this:
<PRE>
       $ ocamlc -pp camlp4o -I +camlp4 -c pa_type.ml
</PRE>
We can test the example file, ``<CODE>col.ml</CODE>'', 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:
<PRE>
       $ camlp4o ./pa_type.cmo pr_o.cmo col.ml
       &lt;W&gt; Grammar extension: in [str_item], some rule has been masked
       type colour =
           Red
         | Green
         | Blue
       let _ = not yet implemented
</PRE>
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 <CODE>str_item</CODE> was already present in the
grammar we used.<BR>
<BR>


To avoid such a warning message, the solution is to add, before the
<CODE>EXTEND</CODE> statement, a <CODE>DELETE_RULE</CODE> statement:
<PRE>
       DELETE_RULE
         Pcaml.str_item: "type"; LIST1 Pcaml.type_declaration SEP "and"
       END;
</PRE>
Let us attack now the function <CODE>gen_print_funcs</CODE>. It receives a
list (since the ``<CODE>type</CODE>'' 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,
<CODE>gen_one_type_print_fun</CODE>, will generate the printer for one type
definition. For the moment, the body is a ``not yet implemented''
statement:
<PRE>
       let fun_name n = "print_" ^ n

       let gen_one_print_fun loc ((loc, n), tpl, tk, cl) =
         &lt;:patt&lt; $lid:fun_name n$ &gt;&gt;, &lt;:expr&lt; not yet implemented &gt;&gt;

       let gen_print_funs loc tdl =
         let pel = List.map (gen_one_print_fun loc) tdl in
         &lt;:str_item&lt; value rec $list:pel$ &gt;&gt;
</PRE>
Recompile the syntax expander file with these functions and test with
``<CODE>col.ml</CODE>'': you can see a function named ``<CODE>print_colour</CODE>''.<BR>
<BR>


Let use improve now ``<CODE>gen_one_print_fun</CODE>''. 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.<BR>
<BR>


In a first version, we are going to ignore the type parameters
``<CODE>tpl</CODE>'': we see later how they intervene in the generated
function and our code will work, for the moment, only for monomorphic
types.<BR>
<BR>


We limit also to the ``sum'' types (i.e. types with constructors); for
other types kinds, we shall generate a function which fails.<BR>
<BR>


We added the function ``<CODE>gen_print_sum</CODE>'' which treats a sum type
by generating a match association for each constructor (function
``<CODE>gen_print_cons</CODE>'') and building the function with the
resulting list.<BR>
<BR>


That function ``<CODE>gen_print_cons</CODE>'' 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
``<CODE>gen_print_cons_patt</CODE>'' generates the pattern part of the case,
and ``<CODE>gen_print_cons_expr</CODE>'' the expression part of the
function, the print statement:<BR>
<BR>


Here is a first (but complete) version of our syntax extension (file
``<CODE>pa_type.ml</CODE>''):
<PRE>
       #load "pa_extend.cmo";;
       #load "q_MLast.cmo";;

       let fun_name n = "print_" ^ n

       let gen_print_cons_patt loc c tl =
         &lt;:patt&lt; $uid:c$ &gt;&gt;

       let gen_print_cons_expr loc c tl =
         &lt;:expr&lt; print_string $str:c$ &gt;&gt;

       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
         &lt;:expr&lt; fun [ $list:pwel$ ] &gt;&gt;

       let gen_one_print_fun loc ((loc, n), tpl, tk, cl) =
         let body =
           match tk with
             &lt;:ctyp&lt; [ $list:cdl$ ] &gt;&gt; -&gt; gen_print_sum loc cdl
           | _ -&gt; &lt;:expr&lt; fun _ -&gt; failwith $str:fun_name n$ &gt;&gt;
         in
         &lt;:patt&lt; $lid:fun_name n$ &gt;&gt;, body

       let gen_print_funs loc tdl =
         let pel = List.map (gen_one_print_fun loc) tdl in
         &lt;:str_item&lt; value rec $list:pel$ &gt;&gt;
       
       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" -&gt;
                   let si1 = &lt;:str_item&lt; type $list:tdl$ &gt;&gt; in
                   let si2 = gen_print_funs loc tdl in
                   &lt;:str_item&lt; declare $si1$; $si2$; end &gt;&gt; ] ]
           ;
         END
</PRE>
We can recompile this version, and test on the example file
``<CODE>col.ml</CODE>'' by pretty printing the result:
<PRE>
       $ 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 -&gt; print_string "Red"
         | Green -&gt; print_string "Green"
         | Blue -&gt; print_string "Blue"
</PRE>
It is what we wanted! This can be used, now, directly with the
compiler without the pretty printing phase:
<PRE>
       $ ocamlc -pp "camlp4o ./pa_type.cmo" -c col.ml
</PRE>
We could also add the directive ``<CODE>#load "./pa_type.cmo";;</CODE>'' in
the beginning of ``<CODE>col.ml</CODE>'' and just compile with:
<PRE>
       $ ocamlc -pp camlp4o -c col.ml
</PRE>
but it is not a good idea, since we may want to use the same source
with the preprocessing or without it.<BR>
<BR>
<TABLE CELLPADDING=0 CELLSPACING=0 WIDTH="100%">
<TR><TD BGCOLOR="#7fff7f"><DIV ALIGN=center><TABLE>
<TR><TD><A NAME="htoc63"><B><FONT SIZE=4>7.5.2</FONT></B></A></TD>
<TD WIDTH="100%" ALIGN=center><B><FONT SIZE=4>Second version: constructors with parameters</FONT></B></TD>
</TR></TABLE></DIV></TD>
</TR></TABLE><BR>
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&nbsp;<A HREF="tutorial004.html#lambda terms">4.7</A>. File ``<CODE>term.ml</CODE>'':
<PRE>
        type term =
            Var of string
          | Func of string * term
          | Appl of term * term
</PRE>
The desired result should be something like this:
<PRE>
        type term =
            Var of string
          | Func of string * term
          | Appl of term * term
        let rec print_term =
          function
            Var x1 -&gt;
              print_string "Var"; print_string " ("; print_string x1;
              print_string ")"
          | Func (x1, x2) -&gt;
              print_string "Func"; print_string " ("; print_string x1
              print_string ", "; print_term x2; print_string ")"
          | Appl (x1, x2) -&gt;
              print_string "Appl"; print_string " ("; print_term x1
              print_string ", "; print_term x2; print_string ")"
</PRE>
Like in the above desired result, we decide to name the parameters
with ``<CODE>x</CODE>'' followed by the number of the parameter, defined by
the following function ``<CODE>param_name</CODE>'':
<PRE>
       let param_name cnt = "x" ^ string_of_int cnt
</PRE>
We need a function ``<CODE>list_mapi</CODE>'', which is like
``<CODE>List.map</CODE>'' 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:
<PRE>
       let list_mapi f l =
         let rec loop cnt =
           function
             x :: l -&gt; f cnt x :: loop (cnt + 1) l
           | [] -&gt; []
         in
         loop 1 l
</PRE>
The function ``<CODE>gen_print_cons_patt</CODE>'' which treats the pattern
part of the match association, is changed like this:
<PRE>
       let gen_print_cons_patt loc c tl =
         let pl =
           list_mapi (fun n _ -&gt; &lt;:patt&lt; $lid:param_name n$ &gt;&gt;)
             tl
         in
         List.fold_left (fun p1 p2 -&gt; &lt;:patt&lt; $p1$ $p2$ &gt;&gt;)
           &lt;:patt&lt; $uid:c$ &gt;&gt; pl
</PRE>
With these changes, the pattern part of the generated function
``<CODE>print_term</CODE>'' is correct. Test it.<BR>
<BR>


For the expression part, we have to generate the call to the printers
for all the constructors parameters. We add a function
``<CODE>gen_print_type</CODE>'' 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:
<PRE>
       let gen_print_type loc =
         function
           &lt;:ctyp&lt; $lid:s$ &gt;&gt; -&gt; &lt;:expr&lt; $lid:fun_name s$ &gt;&gt;
         | _ -&gt; &lt;:expr&lt; fun _ -&gt; print_string "..." &gt;&gt;
</PRE>
We need also a function which generates the call to this printer
function with the constructor parameter:
<PRE>
       let gen_call loc n f = &lt;:expr&lt; $f$ $lid:param_name n$ &gt;&gt;
</PRE>
and a function adding the extra syntax: spaces, parentheses and
commas:
<PRE>
       let gen_print_con_extra_syntax loc el =
         let rec loop =
           function
             [] | [_] as e -&gt; e
           | e :: el -&gt; e :: &lt;:expr&lt; print_string ", " &gt;&gt; :: loop el
         in
         &lt;:expr&lt; print_string " (" &gt;&gt; :: loop el @
         [&lt;:expr&lt; print_string ")" &gt;&gt;]
</PRE>
Now, we can change the function ``<CODE>gen_print_cons_expr</CODE>'' using
all these functions:
<PRE>
       let gen_print_cons_expr loc c tl =
         let pr_con = &lt;:expr&lt; print_string $str:c$ &gt;&gt; in
         match tl with
           [] -&gt; pr_con
         | _ -&gt;
             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
             &lt;:expr&lt; do { $list:el$ } &gt;&gt;
</PRE>
Grouping all these functions together, you can make a second version
of ``<CODE>pa_type.ml</CODE>'' which works with the file ``<CODE>term.ml</CODE>''.
Test it! Try it also with your own programs having sum type definitions.<BR>
<BR>
<TABLE CELLPADDING=0 CELLSPACING=0 WIDTH="100%">
<TR><TD BGCOLOR="#7fff7f"><DIV ALIGN=center><TABLE>
<TR><TD><A NAME="htoc64"><B><FONT SIZE=4>7.5.3</FONT></B></A></TD>
<TD WIDTH="100%" ALIGN=center><B><FONT SIZE=4>Third version: polymorphic types</FONT></B></TD>
</TR></TABLE></DIV></TD>
</TR></TABLE><BR>
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 ``<CODE>mlist</CODE>'' like this. File
``<CODE>mlist.ml</CODE>'':
<PRE>
       type 'a mlist = Nil | Cons of 'a * 'a mlist
</PRE>
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 ``<CODE>print_mlist</CODE>
<CODE>print_int</CODE>'' for an ``<CODE>int mlist</CODE>'', ``<CODE>print_mlist</CODE>
<CODE>print_string</CODE>'' for a ``<CODE>string mlist</CODE>'' and so on.<BR>
<BR>


The desired result for the type ``<CODE>mlist</CODE>'' is:
<PRE>
       type 'a mlist = Nil | Cons of 'a * 'a mlist
       let rec print_mlist pr_a =
         function
           Nil -&gt; print_string "Nil"
         | Cons (x1, x2) -&gt;
             print_string "Cons"; print_string " ("; pr_a x1;
             print_string ", "; print_mlist pr_a x2; print_string ")"
</PRE>
The name of the printer function for a type variable will be
``<CODE>pr_</CODE>'' followed by the type variable name:
<PRE>
       let fun_param_name n = "pr_" ^ n
</PRE>
To add the function parameters to the printer definition (``<CODE>let</CODE>
<CODE>print_mlist</CODE> <CODE>pr_a</CODE> <CODE>= ...</CODE>'' in our example), we
change our function ``<CODE>gen_one_print_func</CODE>'' by inserting them in
the body of the function, just before its result, like this:
<PRE>
         let body =
           List.fold_right
             (fun (v, _) e -&gt;
                &lt;:expr&lt; fun $lid:fun_param_name v$ -&gt; $e$ &gt;&gt;)
             tpl body
         in
</PRE>
For the printing of a type variable (``<CODE>pr_a</CODE> <CODE>x1</CODE>'' in our
example), we add the case of type variables in our function
``<CODE>gen_print_type</CODE>'':
<PRE>
         | &lt;:ctyp&lt; '$s$ &gt;&gt; -&gt; &lt;:expr&lt; $lid:fun_param_name s$ &gt;&gt;
</PRE>
And to generate the printing of types with parameters (we have a
recursive case in our example: ``<CODE>print_mlist</CODE> <CODE>pr_a</CODE>
<CODE>x2</CODE>'' for the constructor parameter of type ``<CODE>'a</CODE>
<CODE>mlist</CODE>''), we add, in the same function, the case of types
applications. But since it needs a recursive call, the function
``<CODE>gen_print_type</CODE>'' is rewritten with a internal recursive
definition.<BR>
<BR>


Here is the complete version:
<PRE>
       #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 -&gt; f cnt x :: loop (cnt + 1) l
           | [] -&gt; []
         in
         loop 1 l

       let gen_print_type loc t =
         let rec eot =
           function
             &lt;:ctyp&lt; $t1$ $t2$ &gt;&gt; -&gt; &lt;:expr&lt; $eot t1$ $eot t2$ &gt;&gt;
           | &lt;:ctyp&lt; $lid:s$ &gt;&gt; -&gt; &lt;:expr&lt; $lid:fun_name s$ &gt;&gt;
           | &lt;:ctyp&lt; '$s$ &gt;&gt; -&gt; &lt;:expr&lt; $lid:fun_param_name s$ &gt;&gt;
           | _ -&gt; &lt;:expr&lt; fun _ -&gt; print_string "..." &gt;&gt;
         in
         eot t

       let gen_call loc n f = &lt;:expr&lt; $f$ $lid:param_name n$ &gt;&gt;

       let gen_print_cons_patt loc c tl =
         let pl =
           list_mapi (fun n _ -&gt; &lt;:patt&lt; $lid:param_name n$ &gt;&gt;)
             tl
         in
         List.fold_left (fun p1 p2 -&gt; &lt;:patt&lt; $p1$ $p2$ &gt;&gt;)
           &lt;:patt&lt; $uid:c$ &gt;&gt; pl

       let gen_print_con_extra_syntax loc el =
         let rec loop =
           function
             [] | [_] as e -&gt; e
           | e :: el -&gt; e :: &lt;:expr&lt; print_string ", " &gt;&gt; :: loop el
         in
         &lt;:expr&lt; print_string " (" &gt;&gt; :: loop el @
         [&lt;:expr&lt; print_string ")" &gt;&gt;]

       let gen_print_cons_expr loc c tl =
         let pr_con = &lt;:expr&lt; print_string $str:c$ &gt;&gt; in
         match tl with
           [] -&gt; pr_con
         | _ -&gt;
             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
             &lt;:expr&lt; do { $list:el$ } &gt;&gt;

       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
         &lt;:expr&lt; fun [ $list:pwel$ ] &gt;&gt;

       let gen_one_print_fun loc ((loc, n), tpl, tk, cl) =
         let body =
           match tk with
             &lt;:ctyp&lt; [ $list:cdl$ ] &gt;&gt; -&gt; gen_print_sum loc cdl
           | _ -&gt; &lt;:expr&lt; fun _ -&gt; failwith $str:fun_name n$ &gt;&gt;
         in
         let body =
           List.fold_right
             (fun (v, _) e -&gt;
                &lt;:expr&lt; fun $lid:fun_param_name v$ -&gt; $e$ &gt;&gt;)
             tpl body
         in
         &lt;:patt&lt; $lid:fun_name n$ &gt;&gt;, body

       let gen_print_funs loc tdl =
         let pel = List.map (gen_one_print_fun loc) tdl in
         &lt;:str_item&lt; value rec $list:pel$ &gt;&gt;
       
       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" -&gt;
                   let si1 = &lt;:str_item&lt; type $list:tdl$ &gt;&gt; in
                   let si2 = gen_print_funs loc tdl in
                   &lt;:str_item&lt; declare $si1$; $si2$; end &gt;&gt; ] ]
           ;
         END
</PRE>
<TABLE CELLPADDING=0 CELLSPACING=0 WIDTH="100%">
<TR><TD BGCOLOR="#7fff7f"><DIV ALIGN=center><TABLE>
<TR><TD><A NAME="htoc65"><B><FONT SIZE=4>7.5.4</FONT></B></A></TD>
<TD WIDTH="100%" ALIGN=center><B><FONT SIZE=4>Improvements</FONT></B></TD>
</TR></TABLE></DIV></TD>
</TR></TABLE><BR>
It is possible to add, the same way, the other kind of types: record
types, abstract types, and so on.<BR>
<BR>


Another interesting improvement is to generate, instead of
``<CODE>print_string</CODE>'' statements, functions of the
``<CODE>Format</CODE>'' library, with pretty printing boxes.<BR>
<BR>


Further, that version can be still improved, by generating only one
``<CODE>Format.fprintf</CODE>'' by printing case (instead of a sequence of
printing statements), using the very useful abbreviations provided by
that library by the prefixes ``<CODE>@</CODE>'' inside the format strings.
<BR>
<BR>
<I><FONT COLOR=maroon>
<br>
For remarks about Camlp4, write to:
<img src="http://cristal.inria.fr/~ddr/images/email.jpg" alt=email align=top>
</FONT></I><HR>
<A HREF="tutorial006.html"><IMG SRC ="previous_motif.gif" ALT="Previous"></A>
<A HREF="index.html"><IMG SRC ="contents_motif.gif" ALT="Up"></A>
<A HREF="tutorial008.html"><IMG SRC ="next_motif.gif" ALT="Next"></A>
</BODY>
</HTML>