--- /dev/null
+(**************************************************************************)
+(* *)
+(* Menhir *)
+(* *)
+(* François Pottier, INRIA Rocquencourt *)
+(* Yann Régis-Gianas, PPS, Université Paris Diderot *)
+(* *)
+(* Copyright 2005-2008 Institut National de Recherche en Informatique *)
+(* et en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the Q Public License version 1.0, with the change *)
+(* described in file LICENSE. *)
+(* *)
+(**************************************************************************)
+
+(* A debugging pretty-printer for [IL]. Newlines are used liberally, so as to
+ facilitate diffs. *)
+
+open IL
+open Printf
+
+module Make (X : sig
+
+ (* This is the channel that is being written to. *)
+
+ val f: out_channel
+
+end) = struct
+
+(* ------------------------------------------------------------------------- *)
+(* XML-style trees. *)
+
+type tree =
+ | Node of string * tree list
+
+let node label ts =
+ Node (label, ts)
+
+(* ------------------------------------------------------------------------- *)
+(* Dealing with newlines and indentation. *)
+
+let maxindent =
+ 120
+
+let whitespace =
+ String.make maxindent ' '
+
+let indentation =
+ ref 0
+
+let line =
+ ref 1
+
+(* [rawnl] is, in principle, the only place where writing a newline
+ character to the output channel is permitted. This ensures that the
+ line counter remains correct. But see also [stretch] and [typ0]. *)
+
+let rawnl f =
+ incr line;
+ output_char f '\n'
+
+let nl f =
+ rawnl f;
+ output f whitespace 0 !indentation
+
+let indent ofs producer f x =
+ let old_indentation = !indentation in
+ let new_indentation = old_indentation + ofs in
+ if new_indentation <= maxindent then
+ indentation := new_indentation;
+ nl f;
+ producer f x;
+ indentation := old_indentation
+
+(* ------------------------------------------------------------------------- *)
+(* Tree printers. *)
+
+let rec print_tree f = function
+ | Node (label, []) ->
+ output_char f '<';
+ output_string f label;
+ output_char f '/';
+ output_char f '>';
+ nl f
+ | Node (label, ts) ->
+ output_char f '<';
+ output_string f label;
+ output_char f '>';
+ indent 2 print_trees f ts;
+ output_char f '<';
+ output_char f '/';
+ output_string f label;
+ output_char f '>';
+ nl f
+
+and print_trees f = function
+ | [] ->
+ ()
+ | t :: ts ->
+ print_tree f t;
+ print_trees f ts
+
+(* ------------------------------------------------------------------------- *)
+(* Expression-to-tree converter. *)
+
+let rec expr e =
+ match e with
+ | EComment (c, e) ->
+ node "comment" [ string c; expr e ]
+ | EPatComment (s, p, e) ->
+ node "patcomment" [ string s; pat p; expr e ]
+ | ELet (pes, e2) ->
+ node "let" ( patexprs pes @ [ expr e2 ])
+ | ERecordWrite (e1, field, e2) ->
+ node "recordwrite" [ expr e1; string field; expr e2 ]
+ | EMatch (e, brs) ->
+ node "match" ( expr e :: branches brs )
+ | ETry (e, brs) ->
+ node "try" ( expr e :: branches brs )
+ | EIfThen (e1, e2) ->
+ node "ifthen" [ expr e1; expr e2 ]
+ | EIfThenElse (e0, e1, e2) ->
+ node "ifthenelse" [ expr e0; expr e1; expr e2 ]
+ | EFun (ps, e) ->
+ node "fun" ( pats ps @ [ expr e ])
+ | EApp (e, args) ->
+ node "app" ( expr e :: exprs args )
+ | ERaise e ->
+ node "raise" [ expr e ]
+ | EMagic e ->
+ node "magic" [ expr e ]
+ | ERepr e ->
+ node "repr" [ expr e ]
+ | EData (d, args) ->
+ node "data" ( string d :: exprs args )
+ | EVar v ->
+ node "var" [ string v ]
+ | ETextual action ->
+ node "text" [ stretch action ]
+ | EUnit ->
+ node "unit" []
+ | EIntConst k ->
+ node "int" [ int k ]
+ | EStringConst s ->
+ node "string" [ string s ]
+ | ETuple es ->
+ node "tuple" ( exprs es )
+ | EAnnot (e, s) ->
+ node "annot" [ expr e; scheme s ]
+ | ERecordAccess (e, field) ->
+ node "recordaccess" [ expr e; string field ]
+ | ERecord fs ->
+ node "record" (fields fs)
+ | EArray fs ->
+ node "array" (exprs fs)
+ | EArrayAccess (e1, e2) ->
+ node "arrayaccess" [ expr e1; expr e2 ]
+
+and exprs es =
+ List.map expr es
+
+and stretch stretch =
+ string stretch.Stretch.stretch_content
+
+and branches brs =
+ List.map branch brs
+
+and branch br =
+ node "branch" [ pat br.branchpat; expr br.branchbody ]
+
+and fields fs =
+ List.map field fs
+
+and field (label, e) =
+ node "field" [ string label; expr e ]
+
+and pats ps =
+ List.map pat ps
+
+and pat = function
+ | PUnit ->
+ node "punit" []
+ | PWildcard ->
+ node "pwildcard" []
+ | PVar x ->
+ node "pvar" [ string x ]
+ | PTuple ps ->
+ node "ptuple" (pats ps)
+ | PAnnot (p, t) ->
+ node "pannot" [ pat p; typ t ]
+ | PData (d, args) ->
+ node "pdata" (string d :: pats args)
+ | PRecord fps ->
+ node "precord" (fpats fps)
+ | POr ps ->
+ node "por" (pats ps)
+
+and fpats fps =
+ List.map fpat fps
+
+and fpat (_, p) =
+ pat p
+
+and patexprs pes =
+ List.map patexpr pes
+
+and patexpr (p, e) =
+ node "patexpr" [ pat p; expr e ]
+
+and string s =
+ node s []
+
+and int k =
+ node (string_of_int k) []
+
+and bool b =
+ node (if b then "true" else "false") []
+
+and scheme s =
+ string "omitted" (* TEMPORARY to be completed, someday *)
+
+and typ t =
+ string "omitted" (* TEMPORARY to be completed, someday *)
+
+(* ------------------------------------------------------------------------- *)
+(* Convert to a tree, then print the tree. *)
+
+let expr e =
+ print_tree X.f (expr e)
+
+end
+
HCoop / bpt / coccinelle.git / blobdiff