X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fcic_notation%2FcicNotationPres.ml;h=cc3a204a4e3874ba3ee55ccb3477932ae66447bc;hb=97c2d258a5c524eb5c4b85208899d80751a2c82f;hp=633d702a90c554c3acc6bf02a6802658579ac66c;hpb=98d5d40127827a5c40e58cb0c9654066f940b0ea;p=helm.git diff --git a/helm/ocaml/cic_notation/cicNotationPres.ml b/helm/ocaml/cic_notation/cicNotationPres.ml index 633d702a9..cc3a204a4 100644 --- a/helm/ocaml/cic_notation/cicNotationPres.ml +++ b/helm/ocaml/cic_notation/cicNotationPres.ml @@ -38,11 +38,10 @@ let to_unicode = Utf8Macro.unicode_of_tex let rec make_attributes l1 = function | [] -> [] | hd :: tl -> - (match !hd with + (match hd with | None -> make_attributes (List.tl l1) tl | Some s -> let p,n = List.hd l1 in - hd := None; (p,n,s) :: make_attributes (List.tl l1) tl) let box_of_mpres = @@ -141,7 +140,7 @@ let semicolon = Mpresentation.Mo ([], ";") let toggle_action children = Mpresentation.Maction ([None, "actiontype", "toggle"], children) -type child_pos = [ `None | `Left | `Right | `Inner ] +type child_pos = [ `Left | `Right | `Inner ] let pp_assoc = function @@ -149,13 +148,6 @@ let pp_assoc = | Gramext.RightA -> "RightA" | Gramext.NonA -> "NonA" -let pp_pos = - function - `None -> "`None" - | `Left -> "`Left" - | `Right -> "`Right" - | `Inner -> "`Inner" - let is_atomic t = let rec aux_mpres = function | Mpres.Mi _ @@ -184,14 +176,19 @@ let is_atomic t = let add_parens child_prec child_assoc child_pos curr_prec t = if is_atomic t then t - else if child_prec < curr_prec - || (child_prec = curr_prec && - child_assoc = Gramext.LeftA && - child_pos <> `Left) - || (child_prec = curr_prec && - child_assoc = Gramext.RightA && - child_pos <> `Right) + else if child_prec >= 0 + && (child_prec < curr_prec + || (child_prec = curr_prec && + child_assoc = Gramext.LeftA && + child_pos = `Right) + || (child_prec = curr_prec && + child_assoc = Gramext.RightA && + child_pos = `Left)) then (* parens should be added *) +(* (prerr_endline "adding parens"; + prerr_endline (Printf.sprintf "child_prec = %d\nchild_assoc = %s\nchild_pos = %s\ncurr_prec= %d" + child_prec (pp_assoc child_assoc) (CicNotationPp.pp_pos + child_pos) curr_prec); *) match t with | Mpresentation.Mobject (_, box) -> mpres_of_box (Box.H ([], [ open_box_paren; box; closed_box_paren ])) @@ -203,49 +200,75 @@ let render ids_to_uris = let module A = Ast in let module P = Mpresentation in let use_unicode = true in - let lookup_uri = function - | None -> None - | Some id -> (try Some (Hashtbl.find ids_to_uris id) with Not_found -> None) + let lookup_uri id = + (try + let uri = Hashtbl.find ids_to_uris id in + Some (UriManager.string_of_uri uri) + with Not_found -> None) in - let make_href xmlattrs xref uris = - let xref_uri = lookup_uri !xref in - let raw_uris = List.map UriManager.string_of_uri !uris in - let uri = - match xref_uri, raw_uris with - | None, [] -> None - | Some uri, [] -> Some uri - | None, raw_uris -> Some (String.concat " " raw_uris) - | Some uri, raw_uris -> Some (String.concat " " (uri :: raw_uris)) + let make_href xmlattrs xref = + let xref_uris = + List.fold_right + (fun xref uris -> + match lookup_uri xref with + | None -> uris + | Some uri -> uri :: uris) + !xref [] + in + let xmlattrs_uris, xmlattrs = + let xref_attrs, other_attrs = + List.partition + (function Some "xlink", "href", _ -> true | _ -> false) + xmlattrs + in + List.map (fun (_, _, uri) -> uri) xref_attrs, + other_attrs in - uris := []; + let uris = + match xmlattrs_uris @ xref_uris with + | [] -> None + | uris -> + Some (String.concat " " + (HExtlib.list_uniq (List.sort String.compare uris))) + in + let xrefs = + match !xref with [] -> None | xrefs -> Some (String.concat " " xrefs) + in + xref := []; xmlattrs @ make_attributes [Some "helm", "xref"; Some "xlink", "href"] - [xref; ref uri] + [xrefs; uris] + in + let make_xref xref = + let xrefs = + match !xref with [] -> None | xrefs -> Some (String.concat " " xrefs) + in + xref := []; + make_attributes [Some "helm","xref"] [xrefs] in - let make_xref xref = make_attributes [Some "helm","xref"] [xref] in (* when mathonly is true no boxes should be generated, only mrows *) (* "xref" is *) - let rec aux xmlattrs mathonly xref pos prec uris t = + let rec aux xmlattrs mathonly xref pos prec t = match t with | A.AttributedTerm _ -> - aux_attributes xmlattrs mathonly xref pos prec uris t + aux_attributes xmlattrs mathonly xref pos prec t | A.Num (literal, _) -> let attrs = (RenderingAttrs.number_attributes `MathML) - @ make_href xmlattrs xref uris + @ make_href xmlattrs xref in Mpres.Mn (attrs, literal) | A.Symbol (literal, _) -> let attrs = (RenderingAttrs.symbol_attributes `MathML) - @ make_href xmlattrs xref uris + @ make_href xmlattrs xref in Mpres.Mo (attrs, to_unicode literal) | A.Ident (literal, subst) | A.Uri (literal, subst) -> let attrs = (RenderingAttrs.ident_attributes `MathML) - @ make_href xmlattrs xref uris + @ make_href xmlattrs xref in let name = Mpres.Mi (attrs, to_unicode literal) in (match subst with @@ -261,101 +284,90 @@ let render ids_to_uris = box_of mathonly (A.H, false, false) [] [ Mpres.Mi ([], name); Mpres.Mo ([], to_unicode "\\def"); - aux [] mathonly xref pos prec uris t ]) + aux [] mathonly xref pos prec t ]) substs)) @ [ closed_brace ]) -(* (CicNotationUtil.dress semicolon - (List.map - (fun (var, t) -> - let var_uri = UriManager.uri_of_string var in - let var_name = UriManager.name_of_uri var_uri in - let href_attr = Some "xlink", "href", var in - box_of mathonly (A.H, false, false) [] [ - Mpres.Mi ([href_attr], var_name); - Mpres.Mo ([], to_unicode "\\def"); - aux [] mathonly xref pos prec uris t ]) - substs)) *) in let substs_maction = toggle_action [ hidden_substs; substs' ] in box_of mathonly (A.H, false, false) [] [ name; substs_maction ]) - | A.Literal l -> aux_literal xmlattrs xref prec uris l + | A.Literal l -> aux_literal xmlattrs xref prec l | A.UserInput -> Mpres.Mtext ([], "%") - | A.Layout l -> aux_layout mathonly xref pos prec uris l + | A.Layout l -> aux_layout mathonly xref pos prec l | A.Magic _ | A.Variable _ -> assert false (* should have been instantiated *) | t -> prerr_endline ("unexpected ast: " ^ CicNotationPp.pp_term t); assert false - and aux_attributes xmlattrs mathonly xref pos prec uris t = + and aux_attributes xmlattrs mathonly xref pos prec t = + let reset = ref false in let new_level = ref None in - let new_xref = ref None in - let new_uris = ref [] in + let new_xref = ref [] in let new_xmlattrs = ref [] in + let new_pos = ref pos in + let reinit = ref false in let rec aux_attribute = function | A.AttributedTerm (attr, t) -> (match attr with | `Loc _ | `Raw _ -> () + | `Level (-1, _) -> reset := true | `Level (child_prec, child_assoc) -> new_level := Some (child_prec, child_assoc) - | `IdRef xref -> new_xref := Some xref - | `Href hrefs -> new_uris := hrefs - | `XmlAttrs attrs -> new_xmlattrs := attrs); + | `IdRef xref -> new_xref := xref :: !new_xref + | `ChildPos pos -> new_pos := pos + | `XmlAttrs attrs -> new_xmlattrs := attrs @ !new_xmlattrs); aux_attribute t | t -> (match !new_level with - | None -> aux !new_xmlattrs mathonly new_xref pos prec new_uris t + | None -> aux !new_xmlattrs mathonly new_xref !new_pos prec t | Some (child_prec, child_assoc) -> let t' = - aux !new_xmlattrs mathonly new_xref pos child_prec new_uris t + aux !new_xmlattrs mathonly new_xref !new_pos child_prec t in - add_parens child_prec child_assoc pos prec t') + if !reset then t' + else add_parens child_prec child_assoc !new_pos prec t') in aux_attribute t -(* function - | `Loc _ - | `Raw _ -> aux xmlattrs mathonly xref pos prec uris t - | `Level (child_prec, child_assoc) -> - let t' = aux xmlattrs mathonly xref pos child_prec uris t in - add_parens child_prec child_assoc pos prec t' - | `IdRef xref -> aux xmlattrs mathonly (Some xref) pos prec uris t - | `Href uris' -> aux xmlattrs mathonly xref pos prec uris' t - | `XmlAttrs xmlattrs -> aux xmlattrs mathonly xref pos prec uris t *) - and aux_literal xmlattrs xref prec uris l = - let attrs = make_href xmlattrs xref uris in + and aux_literal xmlattrs xref prec l = + let attrs = make_href xmlattrs xref in (match l with | `Symbol s -> Mpres.Mo (attrs, to_unicode s) | `Keyword s -> Mpres.Mo (attrs, to_unicode s) | `Number s -> Mpres.Mn (attrs, to_unicode s)) - and aux_layout mathonly xref pos prec uris l = + and aux_layout mathonly xref pos prec l = let attrs = make_xref xref in - let invoke' t = aux [] true (ref None) pos prec uris t in + let invoke' t = aux [] true (ref []) pos prec t in + (* use the one below to reset precedence and associativity *) + let invoke_reinit t = aux [] mathonly xref `Inner ~-1 t in match l with - | A.Sub (t1, t2) -> Mpres.Msub (attrs, invoke' t1, invoke' t2) - | A.Sup (t1, t2) -> Mpres.Msup (attrs, invoke' t1, invoke' t2) - | A.Below (t1, t2) -> Mpres.Munder (attrs, invoke' t1, invoke' t2) - | A.Above (t1, t2) -> Mpres.Mover (attrs, invoke' t1, invoke' t2) + | A.Sub (t1, t2) -> Mpres.Msub (attrs, invoke' t1, invoke_reinit t2) + | A.Sup (t1, t2) -> Mpres.Msup (attrs, invoke' t1, invoke_reinit t2) + | A.Below (t1, t2) -> Mpres.Munder (attrs, invoke' t1, invoke_reinit t2) + | A.Above (t1, t2) -> Mpres.Mover (attrs, invoke' t1, invoke_reinit t2) | A.Frac (t1, t2) - | A.Over (t1, t2) -> Mpres.Mfrac (attrs, invoke' t1, invoke' t2) + | A.Over (t1, t2) -> + Mpres.Mfrac (attrs, invoke_reinit t1, invoke_reinit t2) | A.Atop (t1, t2) -> - Mpres.Mfrac (atop_attributes @ attrs, invoke' t1, invoke' t2) - | A.Sqrt t -> Mpres.Msqrt (attrs, invoke' t) - | A.Root (t1, t2) -> Mpres.Mroot (attrs, invoke' t1, invoke' t2) + Mpres.Mfrac (atop_attributes @ attrs, invoke_reinit t1, + invoke_reinit t2) + | A.Sqrt t -> Mpres.Msqrt (attrs, invoke_reinit t) + | A.Root (t1, t2) -> + Mpres.Mroot (attrs, invoke_reinit t1, invoke_reinit t2) | A.Box ((_, spacing, _) as kind, terms) -> let children = - aux_children mathonly spacing xref pos prec uris + aux_children mathonly spacing xref pos prec (CicNotationUtil.ungroup terms) in box_of mathonly kind attrs children | A.Group terms -> let children = - aux_children mathonly false xref pos prec uris + aux_children mathonly false xref pos prec (CicNotationUtil.ungroup terms) in box_of mathonly (A.H, false, false) attrs children | A.Break -> assert false (* TODO? *) - and aux_children mathonly spacing xref pos prec uris terms = + and aux_children mathonly spacing xref pos prec terms = let find_clusters = let rec aux_list first clusters acc = function @@ -366,30 +378,30 @@ let render ids_to_uris = | (A.Layout A.Break) :: tl -> aux_list first (List.rev acc :: clusters) [] tl | [hd] -> - let pos' = - if first then - pos - else - match pos with - `None -> `Right - | `Inner -> `Inner - | `Right -> `Right - | `Left -> `Inner - in +(* let pos' = + if first then + pos + else + match pos with + `None -> `Right + | `Inner -> `Inner + | `Right -> `Right + | `Left -> `Inner + in *) aux_list false clusters - (aux [] mathonly xref pos' prec uris hd :: acc) [] + (aux [] mathonly xref pos prec hd :: acc) [] | hd :: tl -> - let pos' = - match pos, first with - `None, true -> `Left - | `None, false -> `Inner - | `Left, true -> `Left - | `Left, false -> `Inner - | `Right, _ -> `Inner - | `Inner, _ -> `Inner - in +(* let pos' = + match pos, first with + `None, true -> `Left + | `None, false -> `Inner + | `Left, true -> `Left + | `Left, false -> `Inner + | `Right, _ -> `Inner + | `Inner, _ -> `Inner + in *) aux_list false clusters - (aux [] mathonly xref pos' prec uris hd :: acc) tl + (aux [] mathonly xref pos prec hd :: acc) tl in aux_list true [] [] in @@ -400,7 +412,7 @@ let render ids_to_uris = in List.map boxify_pres (find_clusters terms) in - aux [] false (ref None) `None 0 (ref []) + aux [] false (ref []) `Inner ~-1 let rec print_box (t: boxml_markup) = Box.box2xml print_mpres t