X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Fsoftware%2Fcomponents%2Fcontent_pres%2FtermContentPres.ml;h=29845af1ded26666ec2467cd0e1bf22d17862364;hb=6de1d620529ba16f5cb89588755de3cc6cd5b45b;hp=9f720e33b9a29740d414f6b5a0cd0d793ae0f2ef;hpb=64d7a7dfa840d7279f9af64240ee1f8a69181801;p=helm.git

diff --git a/helm/software/components/content_pres/termContentPres.ml b/helm/software/components/content_pres/termContentPres.ml
index 9f720e33b..29845af1d 100644
--- a/helm/software/components/content_pres/termContentPres.ml
+++ b/helm/software/components/content_pres/termContentPres.ml
@@ -42,18 +42,9 @@ let resolve_binder = function
   | `Forall -> "\\forall"
   | `Exists -> "\\exists"
 
-let add_level_info prec assoc t = Ast.AttributedTerm (`Level (prec, assoc), t)
-let add_pos_info pos t = Ast.AttributedTerm (`ChildPos pos, t)
-let left_pos = add_pos_info `Left
-let right_pos = add_pos_info `Right
-let inner_pos = add_pos_info `Inner
-
-let rec top_pos t = add_level_info ~-1 Gramext.NonA (inner_pos t)
-(*   function
-  | Ast.AttributedTerm (`Level _, t) ->
-      add_level_info ~-1 Gramext.NonA (inner_pos t)
-  | Ast.AttributedTerm (attr, t) -> Ast.AttributedTerm (attr, top_pos t)
-  | t -> add_level_info ~-1 Gramext.NonA (inner_pos t) *)
+let add_level_info prec t = Ast.AttributedTerm (`Level prec, t)
+
+let rec top_pos t = add_level_info ~-1 t
 
 let rec remove_level_info =
   function
@@ -100,30 +91,29 @@ let binder_symbol s =
 let string_of_sort_kind = function
   | `Prop -> "Prop"
   | `Set -> "Set"
-  | `CProp -> "CProp"
+  | `CProp _ -> "CProp"
   | `Type _ -> "Type"
 
 let pp_ast0 t k =
   let rec aux =
     function
     | Ast.Appl ts ->
-        let rec aux_args pos =
+        let rec aux_args level =
           function
           | [] -> []
           | [ last ] ->
-              let last = k last in
-              if pos = `Left then [ left_pos last ] else [ right_pos last ]
+              [ Ast.AttributedTerm (`Level level,k last) ]
           | hd :: tl ->
-              (add_pos_info pos (k hd)) :: aux_args `Inner tl
+              (Ast.AttributedTerm (`Level level, k hd)) :: aux_args 71 tl
         in
-        add_level_info Ast.apply_prec Ast.apply_assoc
-          (hovbox true true (CicNotationUtil.dress break (aux_args `Left ts)))
+        add_level_info Ast.apply_prec 
+          (hovbox true true (CicNotationUtil.dress break (aux_args 70 ts)))
     | Ast.Binder (binder_kind, (id, ty), body) ->
-        add_level_info Ast.binder_prec Ast.binder_assoc
+        add_level_info Ast.binder_prec
           (hvbox false true
             [ binder_symbol (resolve_binder binder_kind);
               k id; builtin_symbol ":"; aux_ty ty; break;
-              builtin_symbol "."; right_pos (k body) ])
+              builtin_symbol "."; k body ])
     | Ast.Case (what, indty_opt, outty_opt, patterns) ->
         let outty_box =
           match outty_opt with
@@ -151,8 +141,11 @@ let pp_ast0 t k =
            space
          ]
         in
-        let mk_case_pattern (head, href, vars) =
-          hbox true false (ident_w_href href head :: List.map aux_var vars)
+        let mk_case_pattern =
+         function
+            Ast.Pattern (head, href, vars) ->
+             hvbox true false (ident_w_href href head :: List.map aux_var vars)
+          | Ast.Wildcard -> builtin_symbol "_"
         in
         let patterns' =
           List.map
@@ -186,37 +179,40 @@ let pp_ast0 t k =
               hbox false false [ builtin_symbol "["; hd ]
               :: aux_patterns tl
         in
-        add_level_info Ast.simple_prec Ast.simple_assoc
+        add_level_info Ast.simple_prec
           (hvbox false false [
             hvbox false false ([match_box]); break;
             hbox false false [ hvbox false false patterns'' ] ])
     | Ast.Cast (bo, ty) ->
-        add_level_info Ast.simple_prec Ast.simple_assoc
+        add_level_info Ast.simple_prec
           (hvbox false true [
             builtin_symbol "("; top_pos (k bo); break; builtin_symbol ":";
             top_pos (k ty); builtin_symbol ")"])
     | Ast.LetIn (var, s, t) ->
-        add_level_info Ast.let_in_prec Ast.let_in_assoc
+        add_level_info Ast.let_in_prec 
           (hvbox false true [
             hvbox false true [
               keyword "let"; space;
               hvbox false true [
-                aux_var var; space; builtin_symbol "\\def"; break; top_pos (k s) ];
-              break; keyword "in" ];
+                aux_var var; space;
+                builtin_symbol "\\def"; break; top_pos (k s) ];
+              break; space; keyword "in"; space ];
             break;
             k t ])
     | Ast.LetRec (rec_kind, funs, where) ->
         let rec_op =
           match rec_kind with `Inductive -> "rec" | `CoInductive -> "corec"
         in
-        let mk_fun (args, (name,ty), body, _) =
-         List.map aux_var args ,k name, HExtlib.map_option k ty, k body in
+        let mk_fun (args, (name,ty), body, rec_param) =
+         List.map aux_var args ,k name, HExtlib.map_option k ty, k body,  
+           fst (List.nth args rec_param)
+        in
         let mk_funs = List.map mk_fun in
         let fst_fun, tl_funs =
           match mk_funs funs with hd :: tl -> hd, tl | [] -> assert false
         in
         let fst_row =
-          let (params, name, ty, body) = fst_fun in
+          let (params, name, ty, body, rec_param) = fst_fun in
           hvbox false true ([
             keyword "let";
             space;
@@ -224,6 +220,7 @@ let pp_ast0 t k =
             space;
             name] @
             params @
+            [space; keyword "on" ; space ; rec_param ;space ] @
             (match ty with None -> [] | Some ty -> [builtin_symbol ":"; ty]) @
             [ builtin_symbol "\\def";
             break;
@@ -231,19 +228,20 @@ let pp_ast0 t k =
         in
         let tl_rows =
           List.map
-            (fun (params, name, ty, body) ->
+            (fun (params, name, ty, body, rec_param) ->
               [ break;
                 hvbox false true ([
                   keyword "and";
                   name] @
                   params @
+                  [space; keyword "on" ; space; rec_param ;space ] @
                   (match ty with
                       None -> []
                     | Some ty -> [builtin_symbol ":"; ty]) @
                   [ builtin_symbol "\\def"; break; body ])])
             tl_funs
         in
-        add_level_info Ast.let_in_prec Ast.let_in_assoc
+        add_level_info Ast.let_in_prec
           ((hvbox false false
             (fst_row :: List.flatten tl_rows
              @ [ break; keyword "in"; break; k where ])))
@@ -321,8 +319,18 @@ let instantiate21 idrefs env l1 =
         assert (CicNotationEnv.well_typed ty value); (* INVARIANT *)
         (* following assertion should be a conditional that makes this
          * instantiation fail *)
-        assert (CicNotationEnv.well_typed expected_ty value);
-        [ add_pos_info pos (CicNotationEnv.term_of_value value) ]
+        if not (CicNotationEnv.well_typed expected_ty value) then
+         begin
+          prerr_endline ("The variable " ^ name ^ " is used with the wrong type in the notation declaration");
+          assert false
+         end;
+        let value = CicNotationEnv.term_of_value value in
+        let value = 
+          match expected_ty with
+          | Env.TermType l -> Ast.AttributedTerm (`Level l,value) 
+          | _ -> value
+        in
+        [ value ]
     | Ast.Magic m -> subst_magic pos env m
     | Ast.Literal l as t ->
         let t = add_idrefs idrefs t in
@@ -342,7 +350,7 @@ let instantiate21 idrefs env l1 =
         let sep =
           match sep_opt with
             | None -> []
-            | Some l -> [ Ast.Literal l ]
+            | Some l -> [ Ast.Literal l; break; space ]
 	in
         let rec instantiate_list acc = function
           | [] -> List.rev acc
@@ -355,7 +363,8 @@ let instantiate21 idrefs env l1 =
               let terms = subst pos env p in
               instantiate_list (CicNotationUtil.group (terms @ sep) :: acc) tl
         in
-        instantiate_list [] values
+        if values = [] then []
+        else [hovbox false false (instantiate_list [] values)]
     | Ast.Opt p ->
         let opt_decls = CicNotationEnv.declarations_of_term p in
         let env =
@@ -461,15 +470,19 @@ let fill_pos_info l1_pattern = l1_pattern
   in
   aux true l1_pattern *)
 
+let counter = ref ~-1 
+let reset () =
+  counter := ~-1;
+  Hashtbl.clear level1_patterns21
+;;
 let fresh_id =
-  let counter = ref ~-1 in
   fun () ->
     incr counter;
     !counter
 
-let add_pretty_printer ~precedence ~associativity l2 l1 =
+let add_pretty_printer l2 (CicNotationParser.CL1P (l1,precedence)) =
   let id = fresh_id () in
-  let l1' = add_level_info precedence associativity (fill_pos_info l1) in
+  let l1' = add_level_info precedence (fill_pos_info l1) in
   let l2' = CicNotationUtil.strip_attributes l2 in
   Hashtbl.add level1_patterns21 id l1';
   pattern21_matrix := (l2', id) :: !pattern21_matrix;
@@ -503,6 +516,8 @@ let head_names names env =
         (match ty, v with
         | Env.ListType ty, Env.ListValue (v :: _) ->
             aux ((name, (ty, v)) :: acc) tl
+        | Env.TermType _, Env.TermValue _  ->
+            aux ((name, (ty, v)) :: acc) tl
         | _ -> assert false)
     | _ :: tl -> aux acc tl
       (* base pattern may contain only meta names, thus we trash all others *)
@@ -516,6 +531,8 @@ let tail_names names env =
         (match ty, v with
         | Env.ListType ty, Env.ListValue (_ :: vtl) ->
             aux ((name, (Env.ListType ty, Env.ListValue vtl)) :: acc) tl
+        | Env.TermType _, Env.TermValue _  ->
+            aux ((name, (ty, v)) :: acc) tl
         | _ -> assert false)
     | binding :: tl -> aux (binding :: acc) tl
     | [] -> acc
@@ -523,6 +540,7 @@ let tail_names names env =
   aux [] env
 
 let instantiate_level2 env term =
+(*   prerr_endline ("istanzio: " ^ CicNotationPp.pp_term term); *)
   let fresh_env = ref [] in
   let lookup_fresh_name n =
     try
@@ -533,17 +551,17 @@ let instantiate_level2 env term =
       new_name
   in
   let rec aux env term =
-(*     prerr_endline ("ENV " ^ CicNotationPp.pp_env env); *)
+(*    prerr_endline ("ENV " ^ CicNotationPp.pp_env env); *)
     match term with
-    | Ast.AttributedTerm (_, term) -> aux env term
+    | Ast.AttributedTerm (a, term) -> (*Ast.AttributedTerm (a, *)aux env term
     | Ast.Appl terms -> Ast.Appl (List.map (aux env) terms)
     | Ast.Binder (binder, var, body) ->
         Ast.Binder (binder, aux_capture_var env var, aux env body)
     | Ast.Case (term, indty, outty_opt, patterns) ->
         Ast.Case (aux env term, indty, aux_opt env outty_opt,
           List.map (aux_branch env) patterns)
-    | Ast.LetIn (var, t1, t2) ->
-        Ast.LetIn (aux_capture_var env var, aux env t1, aux env t2)
+    | Ast.LetIn (var, t1, t3) ->
+        Ast.LetIn (aux_capture_var env var, aux env t1, aux env t3)
     | Ast.LetRec (kind, definitions, body) ->
         Ast.LetRec (kind, List.map (aux_definition env) definitions,
           aux env body)
@@ -571,8 +589,11 @@ let instantiate_level2 env term =
   and aux_capture_var env (name, ty_opt) = (aux env name, aux_opt env ty_opt)
   and aux_branch env (pattern, term) =
     (aux_pattern env pattern, aux env term)
-  and aux_pattern env (head, hrefs, vars) =
-    (head, hrefs, List.map (aux_capture_var env) vars)
+  and aux_pattern env =
+   function
+      Ast.Pattern (head, hrefs, vars) ->
+       Ast.Pattern (head, hrefs, List.map (aux_capture_var env) vars)
+    | Ast.Wildcard -> Ast.Wildcard
   and aux_definition env (params, var, term, i) =
     (List.map (aux_capture_var env) params, aux_capture_var env var, aux env term, i)
   and aux_substs env substs =
@@ -581,7 +602,8 @@ let instantiate_level2 env term =
   and aux_variable env = function
     | Ast.NumVar name -> Ast.Num (Env.lookup_num env name, 0)
     | Ast.IdentVar name -> Ast.Ident (Env.lookup_string env name, None)
-    | Ast.TermVar name -> Env.lookup_term env name
+    | Ast.TermVar (name,(Ast.Level l|Ast.Self l)) -> 
+        Ast.AttributedTerm (`Level l,Env.lookup_term env name)
     | Ast.FreshVar name -> Ast.Ident (lookup_fresh_name name, None)
     | Ast.Ascription (term, name) -> assert false
   and aux_magic env = function
@@ -622,7 +644,7 @@ let instantiate_level2 env term =
               | Env.ListValue (_ :: _) ->
                   instantiate_fold_left 
                     (let acc_binding =
-                      acc_name, (Env.TermType, Env.TermValue acc)
+                      acc_name, (Env.TermType 0, Env.TermValue acc)
                      in
                      aux (acc_binding :: head_names names env') rec_pattern)
                     (tail_names names env')
@@ -644,7 +666,7 @@ let instantiate_level2 env term =
               | Env.ListValue (_ :: _) ->
                   let acc = instantiate_fold_right (tail_names names env') in
                   let acc_binding =
-                    acc_name, (Env.TermType, Env.TermValue acc)
+                    acc_name, (Env.TermType 0, Env.TermValue acc)
                   in
                   aux (acc_binding :: head_names names env') rec_pattern
               | Env.ListValue [] -> aux env base_pattern
@@ -662,3 +684,5 @@ let instantiate_level2 env term =
 
 let _ = load_patterns21 []
 
+
+