added hyperlinks on case pattern heads and outtype

[helm.git] / helm / ocaml / cic_notation / cicNotationRew.ml

diff --git a/helm/ocaml/cic_notation/cicNotationRew.ml b/helm/ocaml/cic_notation/cicNotationRew.ml
index 159d3451e69cdc1782f606014684795f5b6d060a..73f66771f8869695e9c90958b78a73ae88bcab79 100644 (file)
--- a/helm/ocaml/cic_notation/cicNotationRew.ml
+++ b/helm/ocaml/cic_notation/cicNotationRew.ml
@@ -27,6 +27,9 @@ open Printf
 
 module Ast = CicNotationPt
 
+let debug = false
+let debug_print = if debug then prerr_endline else ignore
+
 type pattern_id = int
 type interpretation_id = pattern_id
 type pretty_printer_id = pattern_id
@@ -78,10 +81,13 @@ let rec remove_level_info =
   | t -> t
 
 let add_xml_attrs attrs t = Ast.AttributedTerm (`XmlAttrs attrs, t)
+
 let add_keyword_attrs =
   add_xml_attrs (RenderingAttrs.keyword_attributes `MathML)
+
 let box kind spacing indent content =
   Ast.Layout (Ast.Box ((kind, spacing, indent), content))
+
 let hbox = box Ast.H
 let vbox = box Ast.V
 let hvbox = box Ast.HV
@@ -91,12 +97,20 @@ let break = Ast.Layout Ast.Break
 let reset_href t = t
 let builtin_symbol s = reset_href (Ast.Literal (`Symbol s))
 let keyword k = reset_href (add_keyword_attrs (Ast.Literal (`Keyword k)))
+
 let number s =
   reset_href
     (add_xml_attrs (RenderingAttrs.number_attributes `MathML)
       (Ast.Literal (`Number s)))
+
 let ident i =
   add_xml_attrs (RenderingAttrs.ident_attributes `MathML) (Ast.Ident (i, None))
+
+let ident_w_href href i =
+  match href with
+  | None -> ident i
+  | Some href -> Ast.AttributedTerm (`Href [href], ident i)
+
 let binder_symbol s =
   add_xml_attrs (RenderingAttrs.builtin_symbol_attributes `MathML)
     (builtin_symbol s)
@@ -129,7 +143,7 @@ let pp_ast0 t k =
         let indty_box =
           match indty_opt with
           | None -> []
-          | Some indty -> [ keyword "in"; ident indty ]
+          | Some (indty, href) -> [ keyword "in"; ident_w_href href indty ]
         in
         let match_box =
           hvbox false true [
@@ -137,8 +151,8 @@ let pp_ast0 t k =
             hvbox false false ([ k what ] @ indty_box); break;
             keyword "with" ]
         in
-        let mk_case_pattern (head, vars) =
-          hbox true false (ident head :: List.map aux_var vars)
+        let mk_case_pattern (head, href, vars) =
+          hbox true false (ident_w_href href head :: List.map aux_var vars)
         in
         let patterns' =
           List.map
@@ -311,9 +325,7 @@ let ast_of_acic0 term_info acic k =
     | Cic.AMutInd (id,uri,i,substs) as t ->
         let name = name_of_inductive_type uri i in
         let uri_str = UriManager.string_of_uri uri in
-        let puri_str =
-          uri_str ^ "#xpointer(1/" ^ (string_of_int (i + 1)) ^ ")"
-        in
+        let puri_str = sprintf "%s#xpointer(1/%d)" uri_str (i+1) in
         register_uri id puri_str;
         idref id (Ast.Ident (name, aux_substs substs))
     | Cic.AMutConstruct (id,uri,i,j,substs) ->
@@ -324,6 +336,13 @@ let ast_of_acic0 term_info acic k =
         idref id (Ast.Ident (name, aux_substs substs))
     | Cic.AMutCase (id,uri,typeno,ty,te,patterns) ->
         let name = name_of_inductive_type uri typeno in
+        let uri_str = UriManager.string_of_uri uri in
+        let puri_str = sprintf "%s#xpointer(1/%d)" uri_str (typeno+1) in
+        let ctor_puri j =
+          UriManager.uri_of_string
+            (sprintf "%s#xpointer(1/%d/%d)" uri_str (typeno+1) j)
+        in
+        let case_indty = name, Some (UriManager.uri_of_string puri_str) in
         let constructors = constructors_of_inductive_type uri typeno in
         let rec eat_branch ty pat =
           match (ty, pat) with
@@ -332,14 +351,16 @@ let ast_of_acic0 term_info acic k =
               (CicNotationUtil.name_of_cic_name name, Some (k s)) :: cv, rhs
           | _, _ -> [], k pat
         in
+        let j = ref 0 in
         let patterns =
           List.map2
             (fun (name, ty) pat ->
+              incr j;
               let (capture_variables, rhs) = eat_branch ty pat in
-              ((name, capture_variables), rhs))
+              ((name, Some (ctor_puri !j), capture_variables), rhs))
             constructors patterns
         in
-        idref id (Ast.Case (k te, Some name, Some (k ty), patterns))
+        idref id (Ast.Case (k te, Some case_indty, Some (k ty), patterns))
     | Cic.AFix (id, no, funs) -> 
         let defs = 
           List.map
@@ -547,11 +568,13 @@ let load_patterns21 t =
 let ast_of_acic id_to_sort annterm =
   let term_info = { sort = id_to_sort; uri = Hashtbl.create 211 } in
   let ast = ast_of_acic1 term_info annterm in
+  debug_print ("ast_of_acic -> " ^ CicNotationPp.pp_term ast);
   ast, term_info.uri
 
-let pp_ast term =
-(*   prerr_endline ("pp_ast <- : " ^ CicNotationPp.pp_term term); *)
-  pp_ast1 term
+let pp_ast ast =
+  let ast' = pp_ast1 ast in
+  debug_print ("pp_ast -> " ^ CicNotationPp.pp_term ast');
+  ast'
 
 let fresh_id =
   let counter = ref ~-1 in