(* *)
(**************************************************************************)
-type
- mpres =
- (* token elements *)
+type 'a mpres =
Mi of attr * string
| Mn of attr * string
| Mo of attr * string
| Mspace of attr
| Ms of attr * string
| Mgliph of attr * string
- (* General Layout Schemata *)
- | Mrow of attr * mpres list
- | Mfrac of attr * mpres * mpres
- | Msqrt of attr * mpres
- | Mroot of attr * mpres * mpres
- | Mstyle of attr * mpres
- | Merror of attr * mpres
- | Mpadded of attr * mpres
- | Mphantom of attr * mpres
- | Mfenced of attr * mpres list
- | Menclose of attr * mpres
- (* Script and Limit Schemata *)
- | Msub of attr * mpres * mpres
- | Msup of attr * mpres * mpres
- | Msubsup of attr * mpres * mpres *mpres
- | Munder of attr * mpres * mpres
- | Mover of attr * mpres * mpres
- | Munderover of attr * mpres * mpres *mpres
+ | Mrow of attr * 'a mpres list
+ | Mfrac of attr * 'a mpres * 'a mpres
+ | Msqrt of attr * 'a mpres
+ | Mroot of attr * 'a mpres * 'a mpres
+ | Mstyle of attr * 'a mpres
+ | Merror of attr * 'a mpres
+ | Mpadded of attr * 'a mpres
+ | Mphantom of attr * 'a mpres
+ | Mfenced of attr * 'a mpres list
+ | Menclose of attr * 'a mpres
+ | Msub of attr * 'a mpres * 'a mpres
+ | Msup of attr * 'a mpres * 'a mpres
+ | Msubsup of attr * 'a mpres * 'a mpres *'a mpres
+ | Munder of attr * 'a mpres * 'a mpres
+ | Mover of attr * 'a mpres * 'a mpres
+ | Munderover of attr * 'a mpres * 'a mpres *'a mpres
(* | Multiscripts of ??? NOT IMPLEMEMENTED *)
- (* Tables and Matrices *)
- | Mtable of attr * row list
- (* Enlivening Expressions *)
- | Maction of attr * mpres list
-
-and row = Mtr of attr * mtd list
-
-and mtd = Mtd of attr * mpres
-
+ | Mtable of attr * 'a row list
+ | Maction of attr * 'a mpres list
+ | Mobject of attr * 'a
+and 'a row = Mtr of attr * 'a mtd list
+and 'a mtd = Mtd of attr * 'a mpres
and attr = (string option * string * string) list
;;
(* MathML prefix *)
let prefix = "m";;
-let rec print_mpres =
- let module X = Xml in
- function
- Mi (attr,s) -> X.xml_nempty ~prefix "mi" attr (X.xml_cdata s)
- | Mn (attr,s) -> X.xml_nempty ~prefix "mn" attr (X.xml_cdata s)
- | Mo (attr,s) -> X.xml_nempty ~prefix "mo" attr (X.xml_cdata s)
- | Mtext (attr,s) -> X.xml_nempty ~prefix "mtext" attr (X.xml_cdata s)
- | Mspace attr -> X.xml_empty ~prefix "mspace" attr
- | Ms (attr,s) -> X.xml_nempty ~prefix "ms" attr (X.xml_cdata s)
- | Mgliph (attr,s) -> X.xml_nempty ~prefix "mgliph" attr (X.xml_cdata s)
- (* General Layout Schemata *)
- | Mrow (attr,l) ->
- X.xml_nempty ~prefix "mrow" attr
- [< (List.fold_right (fun x i -> [< (print_mpres x) ; i >]) l [<>])
- >]
- | Mfrac (attr,m1,m2) ->
- X.xml_nempty ~prefix "mfrac" attr
- [< print_mpres m1;
- print_mpres m2
- >]
- | Msqrt (attr,m) ->
- X.xml_nempty ~prefix "msqrt" attr [< print_mpres m >]
- | Mroot (attr,m1,m2) ->
- X.xml_nempty ~prefix "mroot" attr
- [< print_mpres m1;
- print_mpres m2
- >]
- | Mstyle (attr,m) ->
- X.xml_nempty ~prefix "mstyle" attr [< print_mpres m >]
- | Merror (attr,m) ->
- X.xml_nempty ~prefix "merror" attr [< print_mpres m >]
- | Mpadded (attr,m) ->
- X.xml_nempty ~prefix "mpadded" attr [< print_mpres m >]
- | Mphantom (attr,m) ->
- X.xml_nempty ~prefix "mphantom" attr [< print_mpres m >]
- | Mfenced (attr,l) ->
- X.xml_nempty ~prefix "mfenced" attr
- [< (List.fold_right (fun x i -> [< (print_mpres x) ; i >]) l [<>])
- >]
- | Menclose (attr,m) ->
- X.xml_nempty ~prefix "menclose" attr [< print_mpres m >]
- (* Script and Limit Schemata *)
- | Msub (attr,m1,m2) ->
- X.xml_nempty ~prefix "msub" attr
- [< print_mpres m1;
- print_mpres m2
- >]
- | Msup (attr,m1,m2) ->
- X.xml_nempty ~prefix "msup" attr
- [< print_mpres m1;
- print_mpres m2
- >]
- | Msubsup (attr,m1,m2,m3) ->
- X.xml_nempty ~prefix "msubsup" attr
- [< print_mpres m1;
- print_mpres m2;
- print_mpres m3
- >]
- | Munder (attr,m1,m2) ->
- X.xml_nempty ~prefix "munder" attr
- [< print_mpres m1;
- print_mpres m2
- >]
- | Mover (attr,m1,m2) ->
- X.xml_nempty ~prefix "mover" attr
- [< print_mpres m1;
- print_mpres m2
- >]
- | Munderover (attr,m1,m2,m3) ->
- X.xml_nempty ~prefix "munderover" attr
- [< print_mpres m1;
- print_mpres m2;
- print_mpres m3
- >]
-(* | Multiscripts of ??? NOT IMPLEMEMENTED *)
- (* Tables and Matrices *)
- | Mtable (attr, rl) ->
- X.xml_nempty ~prefix "mtable" attr
- [< (List.fold_right (fun x i -> [< (print_mrow x) ; i >]) rl [<>])
- >]
- (* Enlivening Expressions *)
- | Maction (attr, l) ->
- X.xml_nempty ~prefix "maction" attr
- [< (List.fold_right (fun x i -> [< (print_mpres x) ; i >]) l [<>])
- >]
-
-and print_mrow =
+let print_mpres obj_printer mpres =
let module X = Xml in
- function
- Mtr (attr, l) ->
- X.xml_nempty ~prefix "mtr" attr
- [< (List.fold_right (fun x i -> [< (print_mtd x) ; i >]) l [<>])
- >]
-
-and print_mtd =
- let module X = Xml in
- function
- Mtd (attr,m) -> X.xml_nempty ~prefix "mtd" attr [< (print_mpres m) ; X.xml_nempty ~prefix "mphantom" [] (X.xml_nempty ~prefix "mtext" [] (X.xml_cdata "(")) >]
+ let rec aux =
+ function
+ Mi (attr,s) -> X.xml_nempty ~prefix "mi" attr (X.xml_cdata s)
+ | Mn (attr,s) -> X.xml_nempty ~prefix "mn" attr (X.xml_cdata s)
+ | Mo (attr,s) -> X.xml_nempty ~prefix "mo" attr (X.xml_cdata s)
+ | Mtext (attr,s) -> X.xml_nempty ~prefix "mtext" attr (X.xml_cdata s)
+ | Mspace attr -> X.xml_empty ~prefix "mspace" attr
+ | Ms (attr,s) -> X.xml_nempty ~prefix "ms" attr (X.xml_cdata s)
+ | Mgliph (attr,s) -> X.xml_nempty ~prefix "mgliph" attr (X.xml_cdata s)
+ (* General Layout Schemata *)
+ | Mrow (attr,l) ->
+ X.xml_nempty ~prefix "mrow" attr
+ [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>])
+ >]
+ | Mfrac (attr,m1,m2) ->
+ X.xml_nempty ~prefix "mfrac" attr [< aux m1; aux m2 >]
+ | Msqrt (attr,m) ->
+ X.xml_nempty ~prefix "msqrt" attr [< aux m >]
+ | Mroot (attr,m1,m2) ->
+ X.xml_nempty ~prefix "mroot" attr [< aux m1; aux m2 >]
+ | Mstyle (attr,m) -> X.xml_nempty ~prefix "mstyle" attr [< aux m >]
+ | Merror (attr,m) -> X.xml_nempty ~prefix "merror" attr [< aux m >]
+ | Mpadded (attr,m) -> X.xml_nempty ~prefix "mpadded" attr [< aux m >]
+ | Mphantom (attr,m) -> X.xml_nempty ~prefix "mphantom" attr [< aux m >]
+ | Mfenced (attr,l) ->
+ X.xml_nempty ~prefix "mfenced" attr
+ [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>])
+ >]
+ | Menclose (attr,m) -> X.xml_nempty ~prefix "menclose" attr [< aux m >]
+ (* Script and Limit Schemata *)
+ | Msub (attr,m1,m2) ->
+ X.xml_nempty ~prefix "msub" attr [< aux m1; aux m2 >]
+ | Msup (attr,m1,m2) ->
+ X.xml_nempty ~prefix "msup" attr [< aux m1; aux m2 >]
+ | Msubsup (attr,m1,m2,m3) ->
+ X.xml_nempty ~prefix "msubsup" attr [< aux m1; aux m2; aux m3 >]
+ | Munder (attr,m1,m2) ->
+ X.xml_nempty ~prefix "munder" attr [< aux m1; aux m2 >]
+ | Mover (attr,m1,m2) ->
+ X.xml_nempty ~prefix "mover" attr [< aux m1; aux m2 >]
+ | Munderover (attr,m1,m2,m3) ->
+ X.xml_nempty ~prefix "munderover" attr [< aux m1; aux m2; aux m3 >]
+ (* | Multiscripts of ??? NOT IMPLEMEMENTED *)
+ (* Tables and Matrices *)
+ | Mtable (attr, rl) ->
+ X.xml_nempty ~prefix "mtable" attr
+ [< (List.fold_right (fun x i -> [< (aux_mrow x) ; i >]) rl [<>]) >]
+ (* Enlivening Expressions *)
+ | Maction (attr, l) ->
+ X.xml_nempty ~prefix "maction" attr
+ [< (List.fold_right (fun x i -> [< (aux x) ; i >]) l [<>]) >]
+ | Mobject (attr, obj) ->
+ X.xml_nempty ~prefix "msemantics" attr (obj_printer obj)
+ and aux_mrow =
+ let module X = Xml in
+ function
+ Mtr (attr, l) ->
+ X.xml_nempty ~prefix "mtr" attr
+ [< (List.fold_right (fun x i -> [< (aux_mtd x) ; i >]) l [<>])
+ >]
+ and aux_mtd =
+ let module X = Xml in
+ function
+ Mtd (attr,m) -> X.xml_nempty ~prefix "mtd" attr
+ [< (aux m) ;
+ X.xml_nempty ~prefix "mphantom" []
+ (X.xml_nempty ~prefix "mtext" [] (X.xml_cdata "(")) >]
+ in
+ aux mpres
;;
let document_of_mpres pres =
[Some "xmlns","m","http://www.w3.org/1998/Math/MathML" ;
Some "xmlns","helm","http://www.cs.unibo.it/helm" ;
Some "xmlns","xlink","http://www.w3.org/1999/xlink"
- ] (Xml.xml_nempty ~prefix "mstyle" [None, "mathvariant", "normal"; None, "rowspacing", "0.6ex"] (print_mpres pres))
+ ] (Xml.xml_nempty ~prefix "mstyle" [None, "mathvariant", "normal"; None,
+ "rowspacing", "0.6ex"] (print_mpres (fun _ -> assert false) pres))
>]
-
projects / helm.git / blobdiff