/
wsdl2ml.ml
1847 lines (1693 loc) · 78.1 KB
/
wsdl2ml.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(** wsdl2ml:
Convert WSDL file into OCaml support code.
- Currently:
% wsdl2ml <wsdl file>
- Types generated in <wsdl file>Types.ml
*)
let printf = Printf.printf
let eprintf = Printf.eprintf
let sprintf = Printf.sprintf
let fprintf = Printf.fprintf
let kfprintf = Format.kfprintf
let ikfprintf = Format.ikfprintf
module List = Base.List
module String = Base.String
module Char = Base.Char
module O = Ocaml
module Cons = O.Cons
module WC = Wsdl2mlCommon
let debug = ref true
let verbose = ref true
let myname = ref "!\"£$%^&*()" (* Would you use this as a type name? *)
let dname = ref ""
let watchme = ref ""
let collect = ref false
let post_headers = ref true
let mlidl = ref false
let dprintf fmt =
(if !debug then kfprintf else ikfprintf)
(fun _ -> Format.pp_print_flush Format.err_formatter ()) Format.err_formatter fmt
let nprintf fmt =
(if !debug && (!dname = !myname || !myname = "") then kfprintf else ikfprintf)
(fun _ -> Format.pp_print_flush Format.err_formatter ()) Format.err_formatter fmt
let os o = Option.to_string (fun s -> s) o
let ot = function Some x -> x | None -> "_"
(* We can't use Req here because of licence probems, that code
* was taken from the internet. We also can't use Http_client
* because of the ridiculous dependencies between protocols and
* libnet. We would have to write something completely new.
*)
let geturl url =
raise (Failure "geturl: Not implemented")
(*let _, _, content = Req.make_request ~url () in
content*)
(*let get_tree_url url = WC.get_tree_string (geturl url)*)
let rec resolve_imports (ns,(dtd,tree)) =
raise (Failure "resolve_imports: Not implemented")
(*let rec aux imps = function
| WC.E (((_,"import"),atts) as name, trees) ->
(*eprintf "import\n%!";*)
let imps2 =
match WC.find_att ("","namespace") atts, WC.find_att ("","location") atts with
| Some ns2, Some loc ->
(*eprintf "namespace: %s\nlocation: %s\n%!" ns2 loc;*)
(try
let t = get_tree_url loc in
(*eprintf "Tree:\n%s\n%!" (string_of_tree t);*)
resolve_imports (ns2,t)
with Failure _ ->
eprintf "Can't read URL %s\n%!" loc; [])
| _ ->
((*eprintf "namespace or location missing\n%!";*) [])
in
(imps@imps2, WC.E (name, trees))
| WC.E (tag, trees) ->
(*eprintf "tag: %s\n%!" (stag tag);*)
let imps2, trees =
List.fold_left (fun (imps2, trees) tree ->
let imps3, tree = aux [] tree in
(imps2@imps3, trees@[tree])) ([],[]) trees in
(imps@imps2, WC.E (tag, trees))
| WC.D str ->
(*eprintf "data: %s\n%!" str;*)
(imps, WC.D str)
in
let imports, tree = aux [] tree in
(ns,(dtd, tree))::imports*)
(* We actually look for schemas so that we can read XSD files as well... *)
let find_types_ff _types = function
(*| WC.E (((_,"types"),_), trees) -> _types@trees*)
| (WC.E (((_,"schema"),_), _)) as tree -> _types@[tree]
| WC.E _ -> _types
| WC.D _ -> _types
let ste te =
let b = Buffer.create 1024 in
OcamlPrint.Buf.type_expr b te;
Buffer.contents b
let recolon = Str.regexp_string ":"
let tvcnt = ref 0
let tvar () = incr tvcnt; string_of_int (!tvcnt)
let tvstr = function
| [] -> ""
| [tv] -> tv^" "
| tvs -> (String.sconcat ~left:"(" ~right:")" "," tvs)^" "
type idx_type = Idx | Noidx
module TypeOrder : (OrderedTypeSig.S with type t = string list * string) =
struct
type t = string list * string
let compare = Pervasives.compare
end
module TypeMap = BaseMap.Make (TypeOrder)
type 'a typemap = 'a TypeMap.t
let string_of_tn = function
| ([], tn) -> tn
| ([tv], tn) -> tv^" "^tn
| (tvs, tn) -> (String.sconcat ~left:"(" ~right:")" ", " tvs)^" "^tn
let tuple_of_tes = function
| [] -> "()"
| [te] -> ste te
| tes -> String.sconcat ~left:"(" ~right:")" " * " (List.map ste tes)
type ctxt = { mutable first : bool;
mutable cn : int;
tnames : StringSet.t;
ctmap : ((O.type_expr * int) list) StringMap.t;
typmap : (bool * bool * string * string * string option * string option * O.type_expr) typemap;
it : idx_type;
ind : int;
type_t : string;
}
let print_typmap ctxt =
eprintf "typmap:\n";
TypeMap.iter (fun tn (has_con,isel,name,iname,_mino,_maxo,tt) ->
eprintf "%s => %s, %s, %b, %b, %s\n%!" (string_of_tn tn) name iname has_con isel (ste tt)) ctxt.typmap
let get_idx idmap _type =
try
(idmap, List.assoc _type idmap)
with Not_found ->
let idx = List.length idmap in
(((_type,idx)::idmap), idx)
let sidmap idmap = String.sconcat ~left:"[" ~right:"]" "; " (List.map (fun (t,i) -> sprintf "(%s,%d)" (ste t) i) idmap)
let rec inslst a l =
let rec aux = function
| [] -> [a]
| (h::t) as l -> if h = a then l else h::(inslst a t)
in
aux l
let single_type ctxt name t =
eprintf "single_type: name=%s t=%s\n%!" name (ste t);
let idmap = try StringMap.find name ctxt.ctmap with Not_found -> [] in
let teo = List.assoc_opt t idmap in
match teo with
| Some idx -> ctxt, false
| None -> { ctxt with ctmap = StringMap.add name ((t,0)::idmap) ctxt.ctmap }, true
let equalise_types ctxt name t1 t2 =
nprintf "equalise_types: name=%s t1=%s t2=%s\n%!" name (ste t1) (ste t2);
let idmap = try StringMap.find name ctxt.ctmap with Not_found -> [] in
let t1eo = List.assoc_opt t1 idmap in
let t2eo = List.assoc_opt t2 idmap in
let idmap = idmap@(match t1eo, t2eo with
| (Some idx1,Some idx2) ->
if idx1 <> idx2 then eprintf "Warning: non-equal types (%s,%s)\n%!" (ste t1) (ste t2);
[]
| (Some idx1,None) -> [(t2,idx1)]
| (None, Some idx2) -> [(t1,idx2)]
| (None, None) -> [(t1,0); (t2,0)]) in
{ ctxt with ctmap = StringMap.add name idmap ctxt.ctmap }
let pidmap from ctxt name =
let idmap = try StringMap.find name ctxt.ctmap with Not_found -> [] in
nprintf "%s: idmap(%s)=%s\n%!" from name (sidmap idmap)
let tn_prefix = "t"
let tnplen = String.length tn_prefix + 1
let cn_prefix = "C"
let cnplen = String.length cn_prefix + 1
let cc_prefix = "CC"
let ccplen = String.length cc_prefix + 1
let get_ct from bump prev prefix ctxt tvs name _type =
nprintf "get_ct(%s):\n%!" from;
nprintf " name=%s\n _type=%s\n%!" name (ste _type);
match ctxt.it with
| Idx ->
let idmap = try StringMap.find name ctxt.ctmap with Not_found -> [] in
let tn = O.TypeName (tvs, [tn_prefix^"_"^name]) in
let idmap, idx =
match List.assoc_opt tn idmap with
| Some idx -> (inslst (_type,idx) idmap, idx)
| None -> get_idx idmap _type
in
let idxstr = if idx > 0 then "_"^(string_of_int idx) else "" in
let iname = name^idxstr in
let pname = (prefix^"_"^iname) in
nprintf " -> %s\n%!" pname;
pidmap " idmap=" ctxt name;
({ ctxt with ctmap = StringMap.add name idmap ctxt.ctmap }, iname, pname)
| Noidx -> (ctxt, name, (prefix^"_"^name))
let get_typename ?(bump=true) ?(prev=false) from ctxt tvs name _type =
get_ct (from^"->get_typename") bump prev tn_prefix ctxt tvs name _type
let get_consname ?(bump=true) ?(prev=false) from ctxt tvs name _type =
get_ct (from^"->get_consname") bump prev cn_prefix ctxt tvs name _type
(*let get_tconsname ?(bump=true) ?(prev=false) ctxt tvs name _type =
get_ct (from^"->get_tconsname") "get_tconsname" bump prev cc_prefix ctxt tvs name _type*)
(* Really corny, we have to do something about this... *)
let tn2cn new_pfx = function
| O.TypeName (tvs, tn) ->
sprintf "%s %s" (tvstr (List.map ste tvs))
(Str.replace_first (Str.regexp_string tn_prefix) new_pfx (List.last tn))
| te -> raise (Failure (sprintf "tn2cn: %s" (ste te)))
let t_tv tv = O.TypeVar tv
(*let t_dog n = O.TypeName ([], [sprintf "dog_%d" n])*)
let t_unit = O.TypeConst O.TypeUnit
let t_string = O.TypeConst O.TypeString
let t_int = O.TypeConst O.TypeInt
let t_byte = O.TypeName ([],["WC";"t_byte"])
let t_float = O.TypeConst O.TypeFloat
let t_bool = O.TypeConst O.TypeBool
let t_option t = O.TypeName ([t], ["option"])
let t_list t = O.TypeName ([t], ["list"])
let t_choice = function
| [] -> t_unit
| tt -> O.TypeName (tt, [sprintf "%s_choice%d" tn_prefix (List.length tt)])
let t_name0 tvs name = O.TypeName (tvs, [name])
let t_name from ?(prev=false) ctxt tvs _type = function
| "unit" -> ctxt, t_unit
| "string" -> ctxt, t_string
| "boolean" -> ctxt, t_bool
| "int" | "integer" | "short" | "long" | "byte" -> ctxt, t_int
| "double" | "float" | "decimal" -> ctxt, t_float
| name ->
if StringSet.mem name ctxt.tnames
then
let ctxt, _, typename = get_typename (from^"->t_name") ~bump:false ~prev ctxt tvs name _type in
ctxt, O.TypeName (tvs, [typename])
else ctxt, O.TypeName (tvs, [name])
let t_tuple typs = O.TypeTuple typs
(*let t_Time_t = O.TypeName ([],["Time";"t"])*)
let t_dateTime = O.TypeName ([],["WC";"t_dateTime"])
let tv_names tvs = List.fold_left (fun tns -> function O.TypeVar tv -> tns@[tv] | _ -> tns) [] tvs
let typemod name mino maxo _type =
match mino, maxo with
| (Some "0",Some "0") -> nprintf "typemod(0,0): %s -> unit\n%!" name; t_unit
| (Some "0",Some "1")
| (Some "0",None) -> nprintf "typemod(0,1): %s -> option\n%!" name; t_option _type
| (Some "1",Some "1")
| (None,None) -> nprintf "typemod(_,_): %s -> default\n%!" name; _type
| _ -> nprintf "typemod(_): %s -> list\n%!" name; t_list _type
let ta ctxt =
if ctxt.first
then (ctxt.first <- false; "type")
else "and"
let add_type ctxt (tvs,tn) v =
if TypeMap.mem (tvs,tn) ctxt.typmap
then (nprintf "duplicate type: %s %s\n%!" (tvstr tvs) tn; ctxt, false)
else (nprintf "add_type: %s %s\n%!" (tvstr tvs) tn;
{ ctxt with typmap = TypeMap.add (tvs,tn) v ctxt.typmap }, true)
let stdtype ctxt oc mino maxo typo name tname =
let typetype = typemod name mino maxo tname in
let ctxt, iname, typename = get_typename ~bump:false "stdtyp" ctxt [] name typetype in
nprintf "stdtyp: name=%s iname=%s typename=%s\n%!" name iname typename;
let ctxt, _, cn = get_consname ~bump:true "stdtyp" ctxt [] name typetype in
let ctxt, added = add_type ctxt ([],typename) (true,true,name,iname,mino,maxo,typetype) in
nprintf "stdtyp: name=%s typename=%s tname=%s typetype=%s added=%b\n" name iname (ste tname) (ste typetype) added;
if added then fprintf oc "%s %s =\n %s of %s\n" (ta ctxt) typename cn (ste typetype);
ctxt, ([], O.TypeName([],[typename]))
let mktyp ctxt oc mino maxo typo name =
(* TODO: we should look up the value in the given namespace *)
match Option.map (Str.split recolon) typo with
| (Some ["dateTime"])
| (Some [_;"dateTime"]) -> stdtype ctxt oc mino maxo typo name t_dateTime
| (Some ["string"])
| (Some [_;"string"]) -> stdtype ctxt oc mino maxo typo name t_string
| (Some ["int"])
| (Some [_;"int"])
| (Some ["integer"])
| (Some [_;"integer"])
| (Some ["short"])
| (Some [_;"short"])
| (Some ["long"])
| (Some [_;"long"]) -> stdtype ctxt oc mino maxo typo name t_int (* TODO: Range checks *)
| (Some ["byte"])
| (Some [_;"byte"]) -> stdtype ctxt oc mino maxo typo name t_byte (* TODO: Range checks *)
| (Some ["double"])
| (Some [_;"double"])
| (Some ["float"])
| (Some [_;"float"])
| (Some ["decimal"])
| (Some [_;"decimal"]) -> stdtype ctxt oc mino maxo typo name t_float (* TODO: NaN and INF *)
| (Some ["boolean"])
| (Some [_;"boolean"]) -> stdtype ctxt oc mino maxo typo name t_bool
| (Some [tv]) when tv.[0] = '\'' ->
let tvar = t_tv tv in
let typetype = typemod name mino maxo tvar in
let ctxt, iname, typename = get_typename ~bump:false "mktyp" ctxt [tvar] name typetype in
let ctxt, added = add_type ctxt ([tv],typename) (false,true,name,iname,mino,maxo,typetype) in
nprintf "mktyp: name=%s iname=%s typename=%s added=%b\n%!" name iname typename added;
if added then fprintf oc "%s %s %s =\n %s\n" (ta ctxt) tv typename (ste typetype);
ctxt, ([tvar], O.TypeName([tvar],[typename]))
| (Some [_;tn]) ->
let marker_type = t_name0 [] (tn_prefix^"_"^tn) in
let ctxt, tname = t_name "mktyp" ~prev:true ctxt [] marker_type tn in
let typetype = typemod name mino maxo tname in
let ctxt, iname, typename = get_typename ~bump:false "mktyp" ctxt [] name typetype in
let new_type = t_name0 [] typename in
let ctxt, _, cn = get_consname ~bump:true "mktyp" ctxt [] name typetype in
let ctxt, added = add_type ctxt ([],typename) (true,true,name,iname,mino,maxo,typetype) in
if added then fprintf oc "%s %s =\n %s of %s\n" (ta ctxt) typename cn (ste typetype);
nprintf "mktyp: name=%s iname=%s typename=%s\n%!" name iname typename;
nprintf "mktyp: typetype=%s new_type=%s added=%b\n%!" (ste typetype) (ste new_type) added;
ctxt, ([], new_type)
| _ -> raise (Failure (sprintf "Test_wsdl.typemod: Unknown type=(%s %s %s %s)" (ot mino) (ot maxo) (ot typo) name))
let get_element_atts _name atts =
let mino = WC.find_att ("","minOccurs") atts in
let maxo = WC.find_att ("","maxOccurs") atts in
let typo = WC.find_att ("","type") atts in
(*eprintf "element: %s" _name;
(match mino with Some mino -> eprintf " minOccurs=%s" mino | None -> ());
(match maxo with Some maxo -> eprintf " maxOccurs=%s" maxo | None -> ());
(match typo with Some typo -> eprintf " type=%s" typo | None -> ());
eprintf "\n";*)
(mino,maxo,typo)
let get_att_over attname att_opt atts =
match WC.find_att ("",attname) atts with
| Some att -> Some att
| None -> att_opt
let opt_prec opt1 opt2 =
match opt1, opt2 with
| Some v1, Some v2 -> Some v1
| Some v1, None -> Some v1
| None, Some v2 -> Some v2
| None, None -> None
let get_asc trees =
List.fold_left
(fun (alls,seqs,chcs) -> function
| (WC.E (((_,"all"),_),_)) as all -> (alls@[all],seqs,chcs)
| (WC.E (((_,"sequence"),_),_)) as seq -> (alls,seqs@[seq],chcs)
| (WC.E (((_,"choice"),_),_)) as chc -> (alls,seqs,chcs@[chc])
| _ -> (alls,seqs,chcs)) ([],[],[]) trees
let treenames = List.fold_left (fun acc -> function WC.E (((_,name),_),_) -> acc@[name] | _ -> acc) []
let stns trees = String.sconcat ~left:"[" ~right:"]" "; " (treenames trees)
let rec pre_types top ctxt oc trees =
nprintf "pre_types: trees=%s\n%!" (stns trees);
let ctxt, gtyps = List.fold_left (fun (ctxt,acc) -> function
| (WC.E (((_,n),_), _trees)) as typ ->
nprintf "pre_types: %s\n%!" n;
let ctxt, tps = get_elements false ctxt oc [typ] in
(ctxt, acc@tps)
| _ -> assert false) (ctxt,[]) trees in
let alltvs = List.concat (List.map (fun (tvs, _) -> tvs) gtyps) in
ctxt, alltvs, gtyps
and get_sequence top ctxt oc trees =
nprintf "get_sequence: trees=%s\n%!" (stns trees);
let ctxt, alltvs, gtyps = pre_types top ctxt oc trees in
let ctxt, tt =
match gtyps with
| [] -> ctxt, t_unit
| [(tvs, tn)] -> ctxt, tn
| _ ->
let ctxt, tts =
List.fold_left (fun (ctxt, tts) (tvs, tn) ->
let ctxt, typename = ctxt, tn in
(ctxt, tts@[typename])) (ctxt,[]) gtyps in
ctxt, t_tuple tts
in
nprintf "get_sequence: tt=%s\n%!" (ste tt);
ctxt, [alltvs, tt]
and get_choice top ctxt oc trees =
nprintf "get_choice: trees=%s\n%!" (stns trees);
let ctxt, alltvs, gtyps = pre_types top ctxt oc trees in
let cn = ctxt.cn in
ctxt.cn <- ctxt.cn + 1;
let ctxt, tt, chs =
match gtyps with
| [] -> ctxt, t_unit, []
| [(tvs, tn)] ->
let ctxt, typename = t_name "get_choice" ctxt tvs tn (!watchme^(ste tn)) in
let consname = tn2cn (sprintf "Ch%d" cn) typename in
ctxt, t_choice [typename], [(consname, Some typename)]
| _ ->
let ctxt, tts, chs =
List.fold_left (fun (ctxt, tts, chs) (tvs, tn) ->
let ctxt, typename = t_name "get_choice" ctxt tvs tn (!watchme^(ste tn)) in
(* ^^^^^^^--- Do something about this !!! *)
let consname = tn2cn (sprintf "Ch%d" cn) typename in
nprintf "get_choice: typename=%s consname=%s\n%!" (ste typename) consname;
(ctxt, tts@[typename], chs@[(consname, Some typename)])) (ctxt,[],[]) gtyps in
ctxt, t_choice tts, chs
in
let name = sprintf "choice%d" cn in
let typename = sprintf "%s_%s" tn_prefix name in
let ct = O.TypeConstructor chs in
let ctxt, added = add_type ctxt (tv_names alltvs,typename) (true,true,name,name,None,None,ct) in
nprintf "get_choice: ct=%s added=%b\n%!" (ste ct) added;
if added then fprintf oc "%s %s %s_choice%d = %s\n" (ta ctxt) (tvstr (List.map ste alltvs)) tn_prefix cn (ste ct);
let tn = O.TypeName(alltvs,[typename]) in
nprintf "get_choice: tn=%s\n%!" (ste tn);
ctxt, [alltvs, O.TypeName(alltvs,[typename])]
and get_complex_types top isel ctxt oc name mino maxo trees =
nprintf "get_complex_types: trees=%s\n%!" (stns trees);
let ctxt, alltvs, gtyps = pre_types top ctxt oc trees in
let ctxt, consname, tt =
match gtyps with
| [] ->
(* We do actually get this: <xs:complexType name="CreateInternetGatewayType"/> *)
let typename = t_unit in
let typ = typemod ("0"^name) mino maxo typename in
let ctxt, _, consname = get_consname ~bump:false "0 - get_complex_types" ctxt [] name typ in
ctxt, consname, typ
| [(tvs, tn)] ->
let ctxt, typename = ctxt, tn in
let typ = typemod ("1"^name) mino maxo typename in
let ctxt, _, consname = get_consname ~bump:false "1 - get_complex_types" ctxt tvs name typ in
nprintf "\nget_complex_types: consname=%s typename=%s\n%!" consname (ste typename);
ctxt, consname, typ
| _ ->
let ctxt, tts =
List.fold_left (fun (ctxt, tts) (tvs, tn) ->
let ctxt, typename = ctxt, tn in
nprintf "\nget_complex_types: typename=%s\n%!" (ste typename);
(ctxt, tts@[typename])) (ctxt,[]) gtyps in
let typ = typemod ("2"^name) mino maxo (t_tuple tts) in
let ctxt, _, consname = get_consname ~bump:false "2 - get_complex_types" ctxt alltvs name typ in
nprintf "\n\nget_complex_types: consname=%s typ=%s\n\n%!" consname (ste typ);
ctxt, consname, t_tuple tts
in
let ctxt, tname = t_name "get_complex_types" ctxt alltvs tt name in
let ctxt = equalise_types ctxt name tt tname in
let ctxt, iname, typename = get_typename ~bump:true "3 - get_complex_types" ctxt alltvs name tname in
let ctxt, added = add_type ctxt (tv_names alltvs,typename) (true,isel,name,iname,mino,maxo,tt) in
if added
then
(if isel
then fprintf oc "%s %s =\n %s of %s\n\n" (ta ctxt) (ste tname) consname (ste tt)
else fprintf oc "%s %s =\n %s\n\n" (ta ctxt) (ste tname) (ste tt));
let tn = O.TypeName (alltvs,[typename]) in
nprintf "\nget_complex_types: tname=%s tn=%s tt=%s added=%b\n%!" (ste tname) (ste tn) (ste tt) added;
ctxt, [alltvs, tn]
and get_elcts top isel ctxt oc atts trees =
nprintf "get_elcts: trees=%s\n%!" (stns trees);
match WC.find_att ("","name") atts with
| Some name ->
let oldname = !dname in
dname := name;
nprintf "get_elcts: atts=%s\n%!" (WC.satts atts);
let mino, maxo, typo = get_element_atts name atts in
nprintf "get_elcts: name=%s mino='%s' maxo='%s'\n%!" name (os mino) (os maxo);
(match typo with
| Some _ ->
let ctxt, (tvs, tn) = mktyp ctxt oc mino maxo typo name in
nprintf "get_elcts: name=%s tn=%s\n%!" name (ste tn);
let res = ctxt, [(tvs, tn)] in
dname := oldname;
res
| None ->
let res = get_complex_types top isel ctxt oc name mino maxo trees in
dname := oldname;
res)
| None ->
get_sequence top ctxt oc trees
and elname atts =
match WC.find_att ("","name") atts with
| Some name -> name
| None -> "<no name>"
and get_element top ctxt oc = function
| WC.E (((_,"complexType"),atts), trees) ->
let oldname = !dname in
dname := elname atts;
nprintf "get_element(%s): complexType\n%!" (elname atts);
let res = get_elcts top false ctxt oc atts trees in
dname := oldname;
res
| WC.E (((_,"element"),atts), trees) ->
let oldname = !dname in
dname := elname atts;
nprintf "get_element(%s): element\n%!" (elname atts);
let res = get_elcts top true ctxt oc atts trees in
dname := oldname;
res
| WC.E (((_,"all"),atts), trees) ->
nprintf "get_element: all\n%!";
get_elcts top false ctxt oc atts trees
| WC.E (((_,"sequence"),atts), trees) ->
nprintf "get_element: sequence\n%!";
get_sequence top ctxt oc trees
| WC.E (((_,"choice"),atts), trees) ->
nprintf "get_element: choice\n%!";
get_choice top ctxt oc trees
| WC.E (((_,"any"),atts), _trees) ->
nprintf "get_element: any\n%!";
let mino, maxo, _typo = get_element_atts "<any>" atts in
let tv = tvar () in
let ctxt, (tvs, tn) = mktyp ctxt oc mino maxo (Some ("'a"^tv)) ("Any"^tv) in
ctxt, [(tvs, tn)]
| _ -> ctxt, []
and get_elements top ctxt oc trees =
let els = List.filter (function
| WC.E (((_,("complexType"|"element"|"all"|"sequence"|"choice"|"any")),_),_) -> true
| _ -> false) trees in
(*eprintf "%d elements\n%!" (List.length els);*)
List.fold_left (fun (ctxt,acc) el ->
let ctxt, els = get_element top ctxt oc el in
(ctxt,acc@els)) (ctxt,[]) els
let get_schemas ctxt oc tree =
let rec aux = function
| WC.E (((_,"schema"),atts), trees) ->
let _efd = WC.find_att ("", "elementFormDefault") atts in
let _targns = WC.find_att ("", "targetNamespace") atts in
(*eprintf "schema\n";*)
get_elements true ctxt oc trees
| _ -> ctxt, []
in
aux tree
(* Start of generation phases *)
(* Support code *)
let arg_of_tvn tvn = String.sub tvn 1 (String.length tvn - 1)
let arg_of_tv = function O.TypeVar tv -> String.sub tv 1 (String.length tv - 1) | _ -> "_"
let make_type_name tn = String.concat "." tn
let name_of_type_name tn = String.sub tn tnplen (String.length tn - tnplen)
let getvidx name ai =
try
let idx = StringMap.find name ai in
let ai = StringMap.add name (idx+1) ai in
ai, idx
with Not_found ->
StringMap.add name 1 ai, 0
let is_caml_keyword w =
List.mem w [ "assert"; "with"; "while"; "when"; "virtual"; "val"; "type"; "try"; "true"; "to"; "then"; "struct";
"sig"; "rec"; "private"; "or"; "open"; "of"; "object"; "new"; "mutable"; "module"; "mod"; "method";
"match"; "lxor"; "lsr"; "lsl"; "lor"; "let"; "lazy"; "land"; "initializer"; "inherit"; "include"; "in";
"if"; "functor"; "function"; "fun"; "for"; "false"; "external"; "exception"; "end"; "else"; "downto";
"done"; "do"; "constraint"; "class"; "begin"; "asr"; "as"; "and"; ]
let camlvar v = if Char.is_upper v.[0] || is_caml_keyword v then "_"^v else v
let getvname pname cname ai cnt =
let arg =
if pname = "top" || pname = ""
then cname
else if Char.is_upper pname.[0] || is_caml_keyword pname then "_"^pname else pname
in
let ai, idx = getvidx arg ai in
let idxstr = if cnt > 0 && idx > 0 then string_of_int idx else "" in
dname := cname;
(*if pname = "code" then dprintf "getvname: pname=%s cname=%s arg=%s idxstr=%s\n" pname cname arg idxstr;*)
ai, arg^idxstr
let anyre = Str.regexp "Any[0-9]+"
let is_any name = Str.string_match anyre name 0
let choicere = Str.regexp "choice[0-9]+"
let is_choice name = Str.string_match choicere name 0
let deoptarg s = if s = "" then "" else if s.[0] = '?' || s.[0] = '!' then String.sub s 1 (String.length s - 1) else s
let is_type_const = function
| O.TypeVar _ -> true
| O.TypeName (_, ["int"]) -> true
| O.TypeName ([], ["WC";"t_dateTime"]) -> true
| O.TypeName ([], ["WC";"t_byte"]) -> true
| O.TypeConst _ -> true
| O.TypeName (_, [tn]) -> is_any (name_of_type_name tn) (* t_Any !!! *)
| _ -> false
let tvre = Str.regexp "'a\\([0-9]+\\)"
let compare_tv tv1 tv2 =
try
let tf1 = Str.string_match tvre tv1 0 in
let n1 = int_of_string (Str.matched_group 1 tv1) in
let tf2 = Str.string_match tvre tv2 0 in
let n2 = int_of_string (Str.matched_group 1 tv2) in
(match tf1, tf2 with
| true, true -> Pervasives.compare n1 n2
| _, _ -> String.compare tv1 tv2)
with Failure _ | Invalid_argument _ -> String.compare tv1 tv2
let split_idx str =
if str = ""
then "", ""
else
let start = String.length str - 1 in
let p = ref start in
let go = ref true in
while !go && !p >= 0 do if Char.is_digit str.[!p] then decr p else go := false done;
if !p >= 0 then if str.[!p] = '_' then decr p;
let pre = String.sub str 0 (!p + 1) in
let idx = String.sub str (!p + 1) (start - !p) in
pre, idx
(* Make convenience functions *)
let make_type_const pname ai te =
let cname, cnt =
match te with
| O.TypeConst O.TypeString -> "str",1
| O.TypeConst O.TypeInt
| O.TypeConst O.TypeInt64 -> "i64",1
| O.TypeConst O.TypeFloat -> "f",1
| O.TypeConst O.TypeBool -> "b",1
| O.TypeConst O.TypeUnit -> "()",0
| O.TypeName ([], ["int"]) -> "i",1
| O.TypeName ([], ["WC";"t_dateTime"]) -> "dT",1
| O.TypeName ([], ["WC";"t_byte"]) -> "byte",1
| _ -> "v",1
in
let ai, arg = getvname pname cname ai cnt in
[arg], ai, arg
let rec make_type pname tm (ai:int StringMap.t) = function
| O.TypeVar tv ->
let arg = arg_of_tvn tv in
[arg], ai, arg
| O.TypeName (_, ["int"]) as t ->
make_type_const pname ai t
| O.TypeName ([], ["WC";"t_dateTime"]) as t ->
make_type_const pname ai t
| O.TypeName ([], ["WC";"t_byte"]) as t ->
make_type_const pname ai t
| O.TypeName ([tv], ["option"]) ->
let args, ai, tpv = make_type pname tm ai tv in
let itc, spre, spost = if is_type_const tv then true, "", "" else false, "(Some ", ")" in
let args =
if List.length args = 1 && itc
then List.map (fun s -> "?"^s) args
else args
in
args, ai, sprintf "%s(%s)%s" spre tpv spost
| O.TypeName ([tv], ["list"]) ->
let args, ai, tpv = make_type pname tm ai tv in
let p = sprintf "(%s)" (String.concat "," (List.map deoptarg args)) in
let ai, arg = getvname pname "lst" ai 1 in
["!"^arg], ai, sprintf "(List.map (function %s -> %s) %s)" p tpv arg
| O.TypeName (tvs, [tn]) ->
(try
let has_con, isel, _name, iname, _, _, te = TypeMap.find (tv_names tvs,tn) tm in
if is_choice iname
then [iname], ai, iname
else
let args, ai, tpv = make_type _name tm ai te in
args, ai, (if has_con && isel
then sprintf "(%s_%s %s)" cn_prefix iname tpv
else sprintf "%s" tpv)
with Not_found ->
let args, ai, tpvs = make_types pname tm ai tvs in
args, ai, sprintf "(%s %s)" tn (String.concat " " tpvs))
| O.TypeName (tvs, tn) ->
let args, ai, tpvs = make_types pname tm ai tvs in
args, ai, sprintf "(%s %s)" (make_type_name tn) (String.concat " " tpvs)
| (O.TypeConst cte) as te ->
make_type_const pname ai te
| O.TypeTuple tes ->
(match tes with
| [] -> [], ai, "()"
| [te] -> make_type pname tm ai te
| tes ->
let args, ai, tpvs = make_types pname tm ai tes in
args, ai, String.sconcat ~left:"(" ~right:")" ", " tpvs)
(*| O.TypeRef of type_expr*)
(*| O.TypeRecord of (bool (* mutable *) * string * type_expr) list*)
(*| O.TypeConstructor of (string * type_expr option) list*)
(*| O.TypeArrow of type_expr * type_expr*)
(*| O.TypeLabel of bool (* optional *) * string * type_expr*)
(*| O.TypeVerbatim of string*)
| _ -> [], ai, "<dongle>"
and make_types pname tm ai tes =
List.fold_left (fun (args,ai,tpvs) te ->
let args2, ai, tpv = make_type pname tm ai te in
(args@args2), ai, (tpvs@[tpv])) ([],ai,[]) tes
let make_t ctxt oc =
let tvs, cons =
TypeMap.fold (fun (tvs,tn) (has_con,_isel,_name,_iname,_mino,_maxo,_tt) (tvs2,cons) ->
if not has_con || String.sub tn 0 (tnplen-1) <> tn_prefix || tn.[tnplen-1] <> '_'
then (tvs2,cons)
else
let name = String.sub tn tnplen (String.length tn - tnplen) in
if is_choice name
then (tvs2,cons)
else tvs@tvs2, cons@[sprintf " | `%s_%s of %s t_%s\n" cc_prefix name (tvstr tvs) name])
ctxt.typmap ([],[]) in
let tvs = List.uniq ~cmp:String.compare (List.sort compare_tv tvs) in
(*eprintf "tvs: %s\n%!" (String.sconcat ~left:"[" ~right:"]" "; " tvs);*)
let type_t = sprintf "%s t" (tvstr tvs) in
fprintf oc "\ntype %s t = [\n%s]\n" (tvstr tvs) (String.concat "" cons);
{ ctxt with type_t = type_t }
let get_arg param a =
if a = "?_top"
then false, "_top"
else if a.[0] = '?'
then true, a
else if a.[0] = '!'
then
let a = String.sub a 1 (String.length a - 1) in
true, if param then sprintf "?%s" a else sprintf "?(%s=[])" a
else if a = "_top" || a = "()"
then false, a
else false, "~"^a
let get_args ?(param=false) = function
| [] -> "()"
| [tv] -> let isopt, a = get_arg param tv in if isopt then sprintf "%s ()" a else a
| tvs ->
let opts, _nonopts, args =
List.fold_left (fun (opts,nonopts,aa) s ->
let isopt, a = get_arg param s in
if isopt then (opts+1,nonopts,aa@[a]) else (opts,nonopts+1,aa@[a]))
(0,0,[]) tvs
in
let args = String.concat " " args in
if opts > 0 then args^" ()" else args
let _Chre = Str.regexp "\\([ ]*Ch\\([0-9]+\\)_\\)\\(.*+\\)"
let chpre str =
let pre, idx = split_idx str in
if Str.string_match _Chre pre 0
then Str.matched_group 1 pre, Str.matched_group 2 pre, Str.matched_group 3 pre, idx
else "", "", "", ""
let make_choices ctxt oc chname = function
| O.TypeConstructor cl ->
List.iter (fun (name,teo) ->
match teo with
| Some te ->
let pre, num, n, idx = chpre name in (* <--- Won't work with type variables !!!! *)
let ni = n^idx in
let args, _, expr = make_type "top" ctxt.typmap StringMap.empty te in
(*eprintf "make_choices: name=%s pre='%s' n='%s' num=%s\n%!" name pre n num;*)
fprintf oc "let %s_%s %s = (Ch%s_%s %s)\n\n" chname ni (get_args args) num ni expr
| None -> eprintf "Choice without constructors\n%!"
) cl
| _ -> eprintf "Choice not TypeConstructor\n%!"
let is_null mino maxo =
match mino, maxo with
| Some "0", Some "0" -> true
| _, _ -> false
let make_conveniences ctxt oc =
fprintf oc "\n(* Convenience functions *)\n\n";
(*print_typmap ctxt;*)
TypeMap.iter (fun (_tvs,tn) (has_con,isel,_name,iname,_mino,_maxo,tt) ->
if not has_con || String.sub tn 0 (tnplen-1) <> tn_prefix || tn.[tnplen-1] <> '_'
then ()(*eprintf "make_conveniences: rejecting type %s\n%!" tn*)
else
(if is_choice iname
then make_choices ctxt oc iname tt
else
let args, _, expr = make_type "top" ctxt.typmap StringMap.empty tt in
(*eprintf "%s: (%s,%s)\n%!" (string_of_tn (_tvs,tn)) (os _mino) (os _maxo);*)
let cname = if isel then cn_prefix^"_"^iname else "" in
if is_null _mino _maxo
then
(fprintf oc "let make_%s %s =\n (%s None)\n\n" iname (get_args args) cname;
if !collect then fprintf oc "let make_%s_t %s =\n %s (%s None)\n\n"
iname (get_args args) ("`"^cc_prefix^"_"^iname) cname)
else
(fprintf oc "let make_%s %s =\n (%s (%s))\n\n" iname (get_args args) cname expr;
if !collect then fprintf oc "let make_%s_t %s =\n %s (%s (%s))\n\n"
iname (get_args args) ("`"^cc_prefix^"_"^iname) cname expr)))
ctxt.typmap
(* End of convenience functions *)
let make_string_const ai cte =
let convfn, cname, cnt =
match cte with
| O.TypeString -> "","str",1
| O.TypeInt -> "string_of_int","i",1
| O.TypeInt64 -> "Int64.to_string","i64",1
| O.TypeFloat -> "string_of_float","f",1
| O.TypeBool -> "string_of_bool","b",1
| O.TypeUnit -> "","()",0
in
let arg = cname^(if cnt > 0 then string_of_int ai else "") in
arg, ai+cnt, convfn
(* Make post header functions *)
type pname = { pn_idx:bool; pn_opt:bool; pn_ipath:string list; pn_path:string list; }
let string_of_pname {pn_idx; pn_opt; pn_ipath; pn_path;} =
sprintf "(%b,%b,%s,%s)" pn_idx pn_opt (String.concat "." pn_ipath) (String.concat "." pn_path)
let pn_init = { pn_idx=false; pn_opt=false; pn_ipath=[]; pn_path=["top"]; }
let is_pntop = function { pn_path=["top"]; _; } -> true | _ -> false
let set_pn_idx pn idx = { pn with pn_idx = idx }
let set_pn_opt pn opt = { pn with pn_opt = opt }
let add_pn_path pn path = { pn with pn_path=(pn.pn_path@[path]) }
let add_pn_ipath pn path = { pn with pn_ipath=(pn.pn_ipath@[path]) }
let getpnv pn = String.capitalize (camlvar (List.last pn))
let getpn pname =
match pname with
| { pn_idx=true; pn_path=("top"::pn); _; } -> getpnv pn
| { pn_idx=false; pn_path=("top"::pn); _; } -> String.concat "." (List.map String.capitalize pn)
| { pn_path=pn; _; } -> raise (Failure (sprintf "getpn: not Top %s" (String.concat ":" pn)))
let getpns pname =
let pn = getpn pname in
match pname.pn_ipath with
| [] -> false, [pn]
| ipns -> if pn = getpnv [(List.last ipns)] then true, ipns else false, (ipns@[pn])
let getvpn { pn_path=pname; _; } = camlvar (List.last pname)
let is_set s =
let l = String.length s in
if l < 3
then false
else s.[l-3] = 'S' && s.[l-2] = 'e' && s.[l-1] = 't'
let sets = ["filterSet";"valueSet"]
let is_set_name pname = List.exists (fun n -> List.mem n pname.pn_path) sets
let list_idx i = Char.chr ((Char.code 'i')+i)
let ph_type_const pname ai te =
(*if is_set_name pname then eprintf "pname: %s\n%!" (string_of_pname pname);*)
let convfn, cname, typ, cnt =
match te with
| O.TypeConst O.TypeString -> "((","str","):string)",1
| O.TypeConst O.TypeInt -> "string_of_int","i","",1
| O.TypeConst O.TypeInt64 -> "Int64.to_string","i64","",1
| O.TypeConst O.TypeFloat -> "string_of_float","f","",1
| O.TypeConst O.TypeBool -> "string_of_bool","b","",1
| O.TypeConst O.TypeUnit -> "","()","",0
| O.TypeName ([], ["int"]) -> "string_of_int","i","",1
| O.TypeName ([], ["WC";"t_dateTime"]) -> "WC.string_of_dateTime","dT","",1
| O.TypeName ([], ["WC";"t_byte"]) -> "WC.string_of_byte","byte","",1
| _ -> "(fun x -> x)","v","",1
in
let ai, arg = getvname (getvpn pname) cname ai cnt in
if is_pntop pname
then [], ai, "[]"
else
let p =
if pname.pn_idx
then
if List.length pname.pn_ipath > 0
then
let do_last, pns = getpns pname in
let l = List.length pns in
let _Pns = List.map String.capitalize pns in
let pnss = List.mapi (fun i pn ->
if do_last || i < l - 1
then sprintf "\"%s.\"^(string_of_int (__%c+1))" pn (list_idx i)
else sprintf "\"%s\"" pn) _Pns in
let pnv = String.concat "^\".\"^" pnss in
sprintf "[((%s),(%s %s%s))]" pnv convfn arg typ
else sprintf "[(\"%s.\"^(string_of_int (__i+1)),(%s %s%s))]" (getpn pname) convfn arg typ
else sprintf "[(\"%s\",(%s %s%s))]" (getpn pname) convfn arg typ
in
if pname.pn_opt
then ["?"^arg], ai, sprintf "(match %s with Some %s -> %s | None -> [])" arg arg p
else [arg], ai, p
let rec ph_type pname tm (ai:int StringMap.t) = function
| O.TypeVar tv ->
let arg = arg_of_tvn tv in
[arg], ai, arg
| O.TypeName (_, ["int"]) as t ->
ph_type_const pname ai t
| O.TypeName ([], ["WC";"t_dateTime"]) as t ->
ph_type_const pname ai t
| O.TypeName ([], ["WC";"t_byte"]) as t ->
ph_type_const pname ai t
| O.TypeName ([tv], ["option"]) ->
let args, ai, tpv = ph_type (set_pn_opt pname true) tm ai tv in
let itc, spre, spost = if is_type_const tv then true, "", "" else false, "", "" in
let args, tpv =
if List.length args = 1 && itc
then
if is_pntop pname
then [], "[]"
else args, tpv
else args, tpv
in
args, ai, sprintf "%s(%s)%s" spre tpv spost
| O.TypeName ([tv], ["list"]) ->
let args, ai, tpv = ph_type (set_pn_idx pname true) tm ai tv in
let p = sprintf "(%s)" (String.concat "," (List.map deoptarg args)) in
let ai, arg = getvname (getvpn pname) "lst" ai 1 in
["!"^arg], ai, sprintf "(List.concat (Base.List.mapi (fun __%c -> function %s -> %s) %s))"
(list_idx (max (List.length pname.pn_ipath - 1) 0)) p tpv arg
| O.TypeName (tvs, [tn]) ->
(try
let _has_con, isel, _name, iname, _, _, te = TypeMap.find (tv_names tvs,tn) tm in
if is_choice iname
then [iname], ai, iname
else
let pname =
if is_set _name && List.mem _name sets
then add_pn_ipath pname (String.sub _name 0 (String.length _name - 3))
else pname
in
let args, ai, tpv = ph_type (if isel then add_pn_path pname _name else pname) tm ai te in
args, ai, (sprintf "%s" tpv)
with Not_found ->
let args, ai, tpvs = ph_types pname tm ai tvs in
args, ai, sprintf "(%s %s)" tn (String.concat " " tpvs))
| O.TypeName (tvs, tn) ->
let args, ai, tpvs = ph_types pname tm ai tvs in
args, ai, sprintf "(%s %s)" (make_type_name tn) (String.concat " " tpvs)
| (O.TypeConst cte) as te ->
ph_type_const pname ai te
| O.TypeTuple tes ->
(match tes with
| [] -> [], ai, "()"
| [te] -> ph_type pname tm ai te
| tes ->
let args, ai, tpvs = ph_types pname tm ai tes in
args, ai, String.sconcat ~left:"(" ~right:")" " @ " tpvs)
(*| O.TypeRef of type_expr*)
(*| O.TypeRecord of (bool (* mutable *) * string * type_expr) list*)
(*| O.TypeConstructor of (string * type_expr option) list*)
(*| O.TypeArrow of type_expr * type_expr*)
(*| O.TypeLabel of bool (* optional *) * string * type_expr*)
(*| O.TypeVerbatim of string*)
| _ -> [], ai, "<dongle>"
and ph_types pname tm ai tes =
List.fold_left (fun (args,ai,tpvs) te ->
let args2, ai, tpv = ph_type pname tm ai te in
(args@args2), ai, (tpvs@[tpv])) ([],ai,[]) tes
let ph_choices ctxt oc chname = function
| O.TypeConstructor cl ->
List.iter (fun (name,teo) ->
match teo with
| Some te ->
let pre, num, n, idx = chpre name in (* <--- Won't work with type variables !!!! *)
let ni = n^idx in
let args, _, expr = ph_type pn_init ctxt.typmap StringMap.empty te in
(*eprintf "ph_choices: name=%s pre='%s' n='%s' num=%s\n%!" name pre n num;*)
fprintf oc "let ph_%s_%s %s = (%s)\n\n" chname ni (get_args args) (*num ni*) expr