X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2Focaml%2Fcic_notation%2FcicNotationPres.ml;h=633d702a90c554c3acc6bf02a6802658579ac66c;hb=cfda0acfce3f5e0b843bfe2b7ba7c371e5690db0;hp=e7afad578387bd64d156b89991e3b4ed7c2d99e5;hpb=08ecc780b3b0a4cac7ed72cf68c310e4eeffa2c1;p=helm.git diff --git a/helm/ocaml/cic_notation/cicNotationPres.ml b/helm/ocaml/cic_notation/cicNotationPres.ml index e7afad578..633d702a9 100644 --- a/helm/ocaml/cic_notation/cicNotationPres.ml +++ b/helm/ocaml/cic_notation/cicNotationPres.ml @@ -23,7 +23,10 @@ * http://helm.cs.unibo.it/ *) -type mathml_markup = boxml_markup Mpresentation.mpres +module Ast = CicNotationPt +module Mpres = Mpresentation + +type mathml_markup = boxml_markup Mpres.mpres and boxml_markup = mathml_markup Box.box type markup = mathml_markup @@ -34,19 +37,26 @@ let to_unicode = Utf8Macro.unicode_of_tex let rec make_attributes l1 = function | [] -> [] - | None :: tl -> make_attributes (List.tl l1) tl - | Some s :: tl -> - let p,n = List.hd l1 in - (p,n,s) :: make_attributes (List.tl l1) tl + | hd :: tl -> + (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 = function - Mpresentation.Mobject (_, box) -> box + | Mpresentation.Mobject (attrs, box) -> + assert (attrs = []); + box | mpres -> Box.Object ([], mpres) let mpres_of_box = function - Box.Object (_, mpres) -> mpres + | Box.Object (attrs, mpres) -> + assert (attrs = []); + mpres | box -> Mpresentation.Mobject ([], box) let rec genuine_math = @@ -69,11 +79,22 @@ let rec promote_to_math = | Mpresentation.Mobject ([], Box.Object ([], mpres)) -> promote_to_math mpres | math -> math -let small_skip = Mpresentation.Mspace [None, "width", "0.5em"] +let small_skip = + Mpresentation.Mspace (RenderingAttrs.small_skip_attributes `MathML) + +let rec add_mpres_attributes new_attr = function + | Mpresentation.Mobject (attr, box) -> + Mpresentation.Mobject (attr, add_box_attributes new_attr box) + | mpres -> + Mpresentation.set_attr (new_attr @ Mpresentation.get_attr mpres) mpres +and add_box_attributes new_attr = function + | Box.Object (attr, mpres) -> + Box.Object (attr, add_mpres_attributes new_attr mpres) + | box -> Box.set_attr (new_attr @ Box.get_attr box) box let box_of mathonly spec attrs children = match children with - | [t] -> t + | [t] -> add_mpres_attributes attrs t | _ -> let kind, spacing, indent = spec in let dress children = @@ -85,27 +106,27 @@ let box_of mathonly spec attrs children = if mathonly then Mpresentation.Mrow (attrs, dress children) else let attrs' = - (if spacing then [None, "spacing", "0.5em"] else []) - @ (if indent then [None, "indent", "0.5em"] else []) + (if spacing then RenderingAttrs.spacing_attributes `BoxML else []) + @ (if indent then RenderingAttrs.indent_attributes `BoxML else []) @ attrs in match kind with - | CicNotationPt.H -> + | Ast.H -> if List.for_all eligible_math children then Mpresentation.Mrow (attrs', dress (List.map promote_to_math children)) else mpres_of_box (Box.H (attrs', List.map box_of_mpres children)) -(* | CicNotationPt.H when List.for_all genuine_math children -> +(* | Ast.H when List.for_all genuine_math children -> Mpresentation.Mrow (attrs', dress children) *) - | CicNotationPt.V -> + | Ast.V -> mpres_of_box (Box.V (attrs', List.map box_of_mpres children)) - | CicNotationPt.HV -> + | Ast.HV -> mpres_of_box (Box.HV (attrs', List.map box_of_mpres children)) - | CicNotationPt.HOV -> + | Ast.HOV -> mpres_of_box (Box.HOV (attrs', List.map box_of_mpres children)) @@ -136,17 +157,16 @@ let pp_pos = | `Inner -> "`Inner" let is_atomic t = - let module P = Mpresentation in let rec aux_mpres = function - | P.Mi _ - | P.Mo _ - | P.Mn _ - | P.Ms _ - | P.Mtext _ - | P.Mspace _ -> true - | P.Mobject (_, box) -> aux_box box - | P.Maction (_, [mpres]) - | P.Mrow (_, [mpres]) -> aux_mpres mpres + | Mpres.Mi _ + | Mpres.Mo _ + | Mpres.Mn _ + | Mpres.Ms _ + | Mpres.Mtext _ + | Mpres.Mspace _ -> true + | Mpres.Mobject (_, box) -> aux_box box + | Mpres.Maction (_, [mpres]) + | Mpres.Mrow (_, [mpres]) -> aux_mpres mpres | _ -> false and aux_box = function | Box.Space _ @@ -180,7 +200,7 @@ let add_parens child_prec child_assoc child_pos curr_prec t = t let render ids_to_uris = - let module A = CicNotationPt in + let module A = Ast in let module P = Mpresentation in let use_unicode = true in let lookup_uri = function @@ -188,8 +208,8 @@ let render ids_to_uris = | Some id -> (try Some (Hashtbl.find ids_to_uris id) 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 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 @@ -197,34 +217,37 @@ let render ids_to_uris = | None, raw_uris -> Some (String.concat " " raw_uris) | Some uri, raw_uris -> Some (String.concat " " (uri :: raw_uris)) in + uris := []; xmlattrs - @ make_attributes [Some "helm", "xref"; Some "xlink", "href"] [xref; uri] + @ make_attributes [Some "helm", "xref"; Some "xlink", "href"] + [xref; ref uri] 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 = match t with - | A.AttributedTerm (attr, t) -> - aux_attribute xmlattrs mathonly xref pos prec uris t attr + | A.AttributedTerm _ -> + aux_attributes xmlattrs mathonly xref pos prec uris t | A.Num (literal, _) -> let attrs = (RenderingAttrs.number_attributes `MathML) @ make_href xmlattrs xref uris in - P.Mn (attrs, literal) + Mpres.Mn (attrs, literal) | A.Symbol (literal, _) -> let attrs = (RenderingAttrs.symbol_attributes `MathML) @ make_href xmlattrs xref uris in - P.Mo (attrs, to_unicode literal) + Mpres.Mo (attrs, to_unicode literal) | A.Ident (literal, subst) | A.Uri (literal, subst) -> let attrs = (RenderingAttrs.ident_attributes `MathML) - @ make_href xmlattrs xref [] + @ make_href xmlattrs xref uris in - let name = P.Mi (attrs, to_unicode literal) in + let name = Mpres.Mi (attrs, to_unicode literal) in (match subst with | Some [] | None -> name @@ -236,8 +259,8 @@ let render ids_to_uris = (List.map (fun (name, t) -> box_of mathonly (A.H, false, false) [] [ - P.Mi ([], name); - P.Mo ([], to_unicode "\\def"); + Mpres.Mi ([], name); + Mpres.Mo ([], to_unicode "\\def"); aux [] mathonly xref pos prec uris t ]) substs)) @ [ closed_brace ]) @@ -248,23 +271,49 @@ let render ids_to_uris = 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) [] [ - P.Mi ([href_attr], var_name); - P.Mo ([], to_unicode "\\def"); + 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.UserInput -> P.Mtext ([], "%") + | A.UserInput -> Mpres.Mtext ([], "%") | A.Layout l -> aux_layout mathonly xref pos prec uris l | A.Magic _ | A.Variable _ -> assert false (* should have been instantiated *) | t -> prerr_endline ("unexpected ast: " ^ CicNotationPp.pp_term t); assert false - and aux_attribute xmlattrs mathonly xref pos prec uris t = - function + and aux_attributes xmlattrs mathonly xref pos prec uris t = + let new_level = ref None in + let new_xref = ref None in + let new_uris = ref [] in + let new_xmlattrs = ref [] in + let rec aux_attribute = + function + | A.AttributedTerm (attr, t) -> + (match attr with + | `Loc _ + | `Raw _ -> () + | `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); + aux_attribute t + | t -> + (match !new_level with + | None -> aux !new_xmlattrs mathonly new_xref pos prec new_uris t + | Some (child_prec, child_assoc) -> + let t' = + aux !new_xmlattrs mathonly new_xref pos child_prec new_uris t + in + add_parens child_prec child_assoc pos prec t') + in + aux_attribute t +(* function | `Loc _ | `Raw _ -> aux xmlattrs mathonly xref pos prec uris t | `Level (child_prec, child_assoc) -> @@ -272,27 +321,27 @@ let render ids_to_uris = 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 + | `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 (match l with - | `Symbol s -> P.Mo (attrs, to_unicode s) - | `Keyword s -> P.Mo (attrs, to_unicode s) - | `Number s -> P.Mn (attrs, to_unicode s)) + | `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 = let attrs = make_xref xref in - let invoke' t = aux [] true None pos prec uris t in + let invoke' t = aux [] true (ref None) pos prec uris t in match l with - | A.Sub (t1, t2) -> P.Msub (attrs, invoke' t1, invoke' t2) - | A.Sup (t1, t2) -> P.Msup (attrs, invoke' t1, invoke' t2) - | A.Below (t1, t2) -> P.Munder (attrs, invoke' t1, invoke' t2) - | A.Above (t1, t2) -> P.Mover (attrs, invoke' t1, invoke' t2) + | 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.Frac (t1, t2) - | A.Over (t1, t2) -> P.Mfrac (attrs, invoke' t1, invoke' t2) + | A.Over (t1, t2) -> Mpres.Mfrac (attrs, invoke' t1, invoke' t2) | A.Atop (t1, t2) -> - P.Mfrac (atop_attributes @ attrs, invoke' t1, invoke' t2) - | A.Sqrt t -> P.Msqrt (attrs, invoke' t) - | A.Root (t1, t2) -> P.Mroot (attrs, invoke' t1, invoke' 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) | A.Box ((_, spacing, _) as kind, terms) -> let children = aux_children mathonly spacing xref pos prec uris @@ -351,14 +400,16 @@ let render ids_to_uris = in List.map boxify_pres (find_clusters terms) in - aux [] false None `None 0 [] + aux [] false (ref None) `None 0 (ref []) -let rec print_box (t: CicNotationPres.boxml_markup) = +let rec print_box (t: boxml_markup) = Box.box2xml print_mpres t -and print_mpres (t: CicNotationPres.mathml_markup) = +and print_mpres (t: mathml_markup) = Mpresentation.print_mpres print_box t -let render_to_boxml id_to_uri t = +let print_xml = print_mpres + +(* let render_to_boxml id_to_uri t = let xml_stream = print_box (box_of_mpres (render id_to_uri t)) in - Xml.add_xml_declaration xml_stream + Xml.add_xml_declaration xml_stream *)