+++ /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