- lambda-delta: some fixes: now the grundlagen type-checkes through dual_rg

[helm.git] / helm / software / lambda-delta / dual_rg / drgOutput.ml

diff --git a/helm/software/lambda-delta/dual_rg/drgOutput.ml b/helm/software/lambda-delta/dual_rg/drgOutput.ml
index e35e82f4e054002d324cfc4007137af281a80025..5cb9538ddd52e1baba81c08d216d68e4b2c9c15f 100644 (file)
--- a/helm/software/lambda-delta/dual_rg/drgOutput.ml
+++ b/helm/software/lambda-delta/dual_rg/drgOutput.ml
@@ -9,6 +9,7 @@
      \ /   This software is distributed as is, NO WARRANTY.              
       V_______________________________________________________________ *)
 
+module P = Printf
 module U = NUri
 module C = Cps
 module H = Hierarchy
@@ -16,6 +17,47 @@ module Y = Entity
 module X = Library
 module D = Drg
 
+(****************************************************************************)
+
+let pp_attrs out a =
+   let map = function
+      | Y.Name (s, true)  -> out (P.sprintf "%s;" s)
+      | Y.Name (s, false) -> out (P.sprintf "~%s;" s)
+      | Y.Apix i          -> out (P.sprintf "+%i;" i)
+      | Y.Mark i          -> out (P.sprintf "@%i;" i)
+      | Y.Priv            -> out (P.sprintf "%s;" "~") 
+   in
+   List.iter map a
+
+let rec pp_term out = function
+   | D.TSort (a, l)    -> pp_attrs out a; out (P.sprintf "*%u" l)
+   | D.TLRef (a, i, j) -> pp_attrs out a; out (P.sprintf "#(%u,%u)" i j)
+   | D.TGRef (a, u)    -> pp_attrs out a; out (P.sprintf "$")
+   | D.TCast (a, x, y) -> pp_attrs out a; out "<"; pp_term out x; out ">."; pp_term out y
+   | D.TProj (a, x, y) -> assert false
+   | D.TAppl (a, x, y) -> pp_attrs out a; pp_terms "(" ")" out x; pp_term out y
+   | D.TBind (a, x, y) -> pp_attrs out a; pp_bind out x; pp_term out y
+
+and pp_terms bg eg out vs =
+   let rec aux = function
+      | []      -> ()
+      | [v]     -> pp_term out v
+      | v :: vs -> pp_term out v; out ", "; aux vs
+   in
+   out bg; aux vs; out (eg ^ ".")
+
+and pp_bind out = function
+   | D.Abst x -> pp_terms "[:" "]" out x
+   | D.Abbr x -> pp_terms "[=" "]" out x
+   | D.Void x -> out (P.sprintf "[%u]" x)
+
+let rec pp_lenv out = function
+   | D.ESort           -> ()
+   | D.EProj (x, a, y) -> assert false
+   | D.EBind (x, a, y) -> pp_lenv out x; pp_attrs out a; pp_bind out y
+
+(****************************************************************************)
+
 let rec list_iter map l out tab = match l with
    | []       -> ()
    | hd :: tl -> map hd out tab; list_iter map tl out tab
@@ -24,7 +66,13 @@ let list_rev_iter map e ns l out tab =
    let rec aux err f e = function
       | [], []            -> f e
       | n :: ns, hd :: tl -> 
-        let f e = map e hd out tab; f (D.push2 C.err C.start e n ~t:hd) in
+        let f e =
+(*     
+           pp_lenv print_string e; print_string " |- "; 
+          pp_term print_string hd; print_newline ();
+*)
+          map e hd out tab; f (D.push2 C.err C.start e n ~t:hd)
+       in
        aux err f e (ns, tl) 
       | _                 -> err ()
    in
@@ -95,4 +143,6 @@ and exp_eproj e a lenv out tab =
    let attrs = [] in
    X.tag X.proj attrs ~contents:(lenv_iter (exp_bind e) (exp_eproj e) lenv) out tab
 
+(****************************************************************************)
+
 let export_term = exp_term D.empty_lenv