rewritten instantiate code

[helm.git] / helm / software / components / ng_kernel / nCicPp.ml

diff --git a/helm/software/components/ng_kernel/nCicPp.ml b/helm/software/components/ng_kernel/nCicPp.ml
index 27b46431ed49b1eedf2e3be8f52386e0ecc3fc92..33677cb422c2e22191c259376a6e2e7450cd157a 100644 (file)
--- a/helm/software/components/ng_kernel/nCicPp.ml
+++ b/helm/software/components/ng_kernel/nCicPp.ml
@@ -18,45 +18,49 @@ module F = Format
 let head_beta_reduce = ref (fun ~upto:_ _ -> assert false);;
 let set_head_beta_reduce = (:=) head_beta_reduce;;
 
+let get_obj = ref (fun _ -> assert false);;
+let set_get_obj f = get_obj := f;;
+
 let r2s pp_fix_name r = 
   try
     match r with
     | R.Ref (u,R.Ind (_,i,_)) -> 
-        (match NCicLibrary.get_obj u with
+        (match !get_obj u with
         | _,_,_,_, C.Inductive (_,_,itl,_) ->
             let _,name,_,_ = List.nth itl i in name
         | _ -> assert false)
     | R.Ref (u,R.Con (i,j,_)) -> 
-        (match NCicLibrary.get_obj u with
+        (match !get_obj u with
         | _,_,_,_, C.Inductive (_,_,itl,_) ->
             let _,_,_,cl = List.nth itl i in
             let _,name,_ = List.nth cl (j-1) in name
         | _ -> assert false)
     | R.Ref (u,(R.Decl | R.Def _)) -> 
-        (match NCicLibrary.get_obj u with
+        (match !get_obj u with
         | _,_,_,_, C.Constant (_,name,_,_,_) -> name
         | _ -> assert false)
     | R.Ref (u,(R.Fix (i,_,_)|R.CoFix i)) ->
-        (match NCicLibrary.get_obj u with
+        (match !get_obj u with
         | _,_,_,_, C.Fixpoint (_,fl,_) -> 
             if pp_fix_name then
               let _,name,_,_,_ = List.nth fl i in name
             else 
-              NUri.name_of_uri u ^"("^ string_of_int i ^ ")"
+              NUri.name_of_uri u (*^"("^ string_of_int i ^ ")"*)
         | _ -> assert false)
   with 
-  | NCicLibrary.ObjectNotFound _ 
+  | NCicEnvironment.ObjectNotFound _ 
   | Failure "nth" 
   | Invalid_argument "List.nth" -> R.string_of_reference r
-
 ;;
 
 let string_of_implicit_annotation = function
   | `Closed -> "▪"
   | `Type -> ""
   | `Hole -> "□"
+  | `Tagged s -> "[\"" ^ s ^ "\"]"
   | `Term -> "Term"
   | `Typeof x -> "Ty("^string_of_int x^")"
+  | `Vector -> "…"
 ;;
 
 let ppterm ~formatter:f ~context ~subst ~metasenv:_ ?(inside_fix=false) t =
@@ -131,8 +135,14 @@ let ppterm ~formatter:f ~context ~subst ~metasenv:_ ?(inside_fix=false) t =
             2 (List.tl pl));
         end;
      F.fprintf f "]@] @]";
-  | C.Appl [] | C.Appl [_] | C.Appl (C.Appl _::_) -> 
-      F.fprintf f "BAD APPLICATION"
+  | C.Appl [] -> 
+      F.fprintf f "BAD APPLICATION: empty list"
+  | C.Appl [x] ->
+      F.fprintf f "BAD APPLICATION: just the head: ";
+      aux ctx x
+  | C.Appl (C.Appl _ as x::_) -> 
+      F.fprintf f "BAD APPLICATION: appl of appl with head: ";
+      aux ctx x
   | C.Appl (C.Meta (n,lc) :: args) when List.mem_assoc n subst -> 
       let _,_,t,_ = List.assoc n subst in
       let hd = NCicSubstitution.subst_meta lc t in
@@ -164,16 +174,7 @@ let ppterm ~formatter:f ~context ~subst ~metasenv:_ ?(inside_fix=false) t =
             (List.map (NCicSubstitution.lift shift) (List.tl l));
          end;
        F.fprintf f "])"
-  | C.Sort C.Prop -> F.fprintf f "Prop"
-  | C.Sort (C.Type []) -> F.fprintf f "Type0"
-  | C.Sort (C.Type [false, u]) -> F.fprintf f "%s" (NUri.name_of_uri u)
-  | C.Sort (C.Type [true, u]) -> F.fprintf f "S(%s)" (NUri.name_of_uri u)
-  | C.Sort (C.Type l) -> 
-      F.fprintf f "Max(";
-      aux ctx (C.Sort (C.Type [List.hd l]));
-      List.iter (fun x -> F.fprintf f ",";aux ctx (C.Sort (C.Type [x])))
-       (List.tl l);
-      F.fprintf f ")"
+  | C.Sort s -> NCicEnvironment.ppsort f s
  in 
   aux ~toplevel:true (List.map fst context) t
 ;;
@@ -207,13 +208,28 @@ let rec ppcontext ~formatter ?(sep="\n") ~subst ~metasenv = function
       F.fprintf formatter "%s" sep
 ;;
 
+let ppmetaattrs =
+ function
+    [] -> ""
+  | attrs ->
+   "(" ^
+    String.concat ","
+     (List.map
+       (function
+           `IsSort -> "sort"
+         | `Name n -> "name=" ^ n
+         | `InScope -> "in_scope"
+         | `OutScope n -> "out_scope:" ^ string_of_int n
+       ) attrs) ^
+    ")"
+;;
+
 let rec ppmetasenv ~formatter ~subst metasenv = function
   | [] -> ()
-  | (i,(name, ctx, ty)) :: tl ->
+  | (i,(attrs, ctx, ty)) :: tl ->
       F.fprintf formatter "@[<hov 2>";
-      let name = match name with Some n -> "("^n^")" | _ -> "" in
       ppcontext ~formatter ~sep:"; " ~subst ~metasenv ctx;
-      F.fprintf formatter "@;⊢@;?%d%s :@;" i name;
+      F.fprintf formatter "@;⊢@;?%d%s :@;" i (ppmetaattrs attrs);
       ppterm ~formatter ~metasenv ~subst ~context:ctx ty;
       F.fprintf formatter "@]@\n";
       ppmetasenv ~formatter ~subst metasenv tl
@@ -225,10 +241,9 @@ let ppmetasenv ~formatter ~subst metasenv =
 
 let rec ppsubst ~formatter ~subst ~metasenv = function
   | [] -> ()
-  | (i,(name, ctx, t, ty)) :: tl ->
-      let name = match name with Some n -> "("^n^")" | _ -> "" in
+  | (i,(attrs, ctx, t, ty)) :: tl ->
       ppcontext ~formatter ~sep:"; " ~subst ~metasenv ctx;
-      F.fprintf formatter " ⊢ ?%d%s := " i name;
+      F.fprintf formatter " ⊢ ?%d%s := " i (ppmetaattrs attrs);
       ppterm ~formatter ~metasenv ~subst ~context:ctx t;
       F.fprintf formatter " : ";
       ppterm ~formatter ~metasenv ~subst ~context:ctx ty;