Skip to content
This repository
tag: v252
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 1852 lines (1698 sloc) 80.174 kb
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 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851
(*
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.TypeChar -> "c",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.TypeChar -> "(String.make 1)","c",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.TypeChar -> "(String.make 1)","c","",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
                   | None -> eprintf "Choice without constructors\n%!"
                ) cl
  | _ -> eprintf "Choice not TypeConstructor\n%!"

let make_phs ctxt oc =
  fprintf oc "\n(* Post header functions *)\n\n";
  (*print_typmap ctxt;*)
  TypeMap.fold (fun (_tvs,tn) (has_con,isel,name,iname,mino,maxo,tt) phargmap ->
                  if not has_con || String.sub tn 0 (tnplen-1) <> tn_prefix || tn.[tnplen-1] <> '_'
                  then phargmap(*eprintf "make_phs: rejecting type %s\n%!" tn*)
                  else
                    (if is_choice iname
                     then (ph_choices ctxt oc iname tt; phargmap)
                     else
                       let args, _, expr = ph_type pn_init ctxt.typmap StringMap.empty tt in
                       (*eprintf "%s: (%s,%s)\n%!" (string_of_tn (_tvs,tn)) (os _mino) (os _maxo);*)
                       let argstr = get_args args in
                       if is_null mino maxo
                       then fprintf oc "let ph_%s %s =\n [(\"Action\",\"%s\")]\n\n" iname argstr name
                       else fprintf oc "let ph_%s %s =\n [(\"Action\",\"%s\")]@(%s)\n\n" iname argstr name expr;
                       (name,(get_args ~param:true args))::phargmap))
               ctxt.typmap []

(* End of post header functions *)

(* XML output functions *)

let make_toxml_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.TypeChar -> "(String.make 1)","c",1
    | O.TypeUnit -> "","()",0
  in
  let arg = cname^(if cnt > 0 then string_of_int ai else "") in
  arg, ai+cnt, convfn

let rec arity = function
  | O.TypeVar _ -> 1
  | O.TypeName _ -> 1
  | O.TypeConst _ -> 1
  | O.TypeRef te -> arity te
  | O.TypeTuple tes -> List.length tes
  | O.TypeRecord _ -> 1
  | O.TypeConstructor _ -> 1
  | O.TypeArrow _ -> 1
  | O.TypeLabel (_,_,te) -> arity te
  | O.TypeVerbatim s -> raise (Failure (sprintf "Can't determine arity of verbatim: %s" s))

let rec tvs_of_te = function
  | O.TypeVar s -> [s]
  | O.TypeName (tes,_) -> List.fold_left (fun tvs te -> tvs@(tvs_of_te te)) [] tes
  | O.TypeConst _ -> []
  | O.TypeRef te -> tvs_of_te te
  | O.TypeTuple tes -> List.fold_left (fun tvs te -> tvs@(tvs_of_te te)) [] tes
  | O.TypeRecord trs -> List.fold_left (fun tvs (_,_,te) -> tvs@(tvs_of_te te)) [] trs
  | O.TypeConstructor tcs -> List.fold_left (fun tvs -> function (_,Some te) -> tvs@(tvs_of_te te) | _ -> tvs) [] tcs
  | O.TypeArrow (te1,te2) -> (tvs_of_te te1)@(tvs_of_te te2)
  | O.TypeLabel (_,_,te) -> tvs_of_te te
  | O.TypeVerbatim s -> raise (Failure (sprintf "Can't determine type variables of verbatim: %s" s))

let make_tvconv tv = "toxml_"^(arg_of_tvn tv)

let rec make_toxml tm ai = function
  | O.TypeVar tv ->
      eprintf "typevar: %s\n%!" tv;
      let arg = arg_of_tvn tv in
      let confn = sprintf "toxml_%s" arg in
      [], [arg], ai, sprintf "[%s %s]" confn arg
  | O.TypeName ([], ["WC";"t_dateTime"]) ->
      let arg = "dT"^(string_of_int ai) in
      [], [arg], ai+1, sprintf "[(WC.D (WC.string_of_dateTime %s))]" arg
  | O.TypeName ([], ["WC";"t_byte"]) ->
      let arg = "byte"^(string_of_int ai) in
      [], [arg], ai+1, sprintf "[(WC.D (WC.string_of_byte %s))]" arg
  | O.TypeName ([tv], ["option"]) ->
      let tvconvs, args, ai, tpv = make_toxml tm ai tv in
      tvconvs, args, ai, sprintf "(%s)" tpv
  | O.TypeName ([tv], ["list"]) ->
      let tvconvs, args, ai, tpv = make_toxml tm ai tv in
      tvconvs, args, ai, sprintf "((fun %s -> %s) %s)" (tvstr args) tpv (tvstr args)
  | O.TypeName (tvs, [tn]) ->
      (try
         let has_con, _isel, _name, iname, _, _, te = TypeMap.find (tv_names tvs,tn) tm in
         let arg = sprintf "v_%d" ai in
         let istv, tv = match te with O.TypeVar tv -> true, tv | _ -> false, "" in
         let tvs = tvs_of_te te in
         (*eprintf "tvs: %s\n%!" (String.concat "," tvs);*)
         let tvconv, tpv =
           if has_con
           then
             let tvconv = if tvs = [] then "" else make_tvconv (List.hd tvs) in
             (if tvconv <> "" then [tvconv] else []), sprintf "(toxml_%s %s %s)" iname tvconv arg
           else
             if istv
             then
               let tvconv = "toxml_"^(arg_of_tvn tv) in
               [tvconv], sprintf "(%s %s)" tvconv arg
             else [], sprintf "%s" arg
         in
         tvconv, [arg], ai+1, tpv
       with Not_found ->
         let tvconvs, args, ai, tpvs = make_toxmls tm ai tvs in
         tvconvs, args, ai, sprintf "(%s %s)" tn (String.concat " " tpvs))
  | O.TypeName (tvs, tn) ->
      let tvconvs, args, ai, tpvs = make_toxmls tm ai tvs in
      tvconvs, args, ai, sprintf "[%s (* arity:%d *) %s]" (make_type_name tn) (List.length tn) (String.concat " " tpvs)
  | O.TypeConst O.TypeUnit ->
      [], ["()"], ai, "[]"
  | O.TypeConst cte ->
      let arg, ai, convfn = make_toxml_const ai cte in
      [], [arg], ai, sprintf "[(WC.D (%s %s))]" convfn arg
  | O.TypeTuple tes ->
      (match tes with
       | [] -> [], [], ai, "()"
       | [te] -> make_toxml tm ai te
       | tes ->
           let tvconvs, args, ai, tpvs = make_toxmls tm ai tes in
           tvconvs, args, ai, sprintf "%s" (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_toxmls tm ai tes =
  List.fold_left (fun (tvconvs,args,ai,tpvs) te ->
                    let tvconvs2, args2, ai, tpv = make_toxml tm ai te in
                    (tvconvs@tvconvs2), (args@args2), ai, (tpvs@[tpv])) ([],[],ai,[]) tes

let int_of_occurs = function
  | Some "unbounded" -> max_int
  | Some n -> (try int_of_string n with
               | Failure "int_of_string" ->
                   raise (Failure (sprintf "int_of_occurs: unknown occurs value %s" n)))
  | None -> -1

let toxml_choices tm ai = function
  | O.TypeConstructor cl ->
      let tvconvs, args, ai, tpvs =
        List.fold_left (fun (tvconvs,args,ai,tpvs) (name,teo) ->
                          match teo with
                          | Some te ->
                              let tvconvs2, args2, ai, tpv = make_toxml tm ai te in
                              (tvconvs@tvconvs2), (args@args2), ai, tpvs@[sprintf "%s %s -> %s" name (tvstr args2) tpv]
                          | None -> assert false)
                       ([], [], ai, []) cl in
      tvconvs, args, ai, sprintf "%s" (String.sconcat ~left:"(function\n " ~right:")" "\n | " tpvs)
  | _ ->
      eprintf "toxml_choices: not a TypeConstructor\n%!";
      [], [], ai, "<dongle>"

let make_to_xml ctxt oc =
  fprintf oc "\n(* XML output functions *)\n\n";
  let pes, choices =
    TypeMap.fold (fun (_tvs,tn) (has_con,isel,name,iname,mino,maxo,tt) (acc,choices) ->
                    if not has_con || String.sub tn 0 (tnplen-1) <> tn_prefix || tn.[tnplen-1] <> '_'
                    then (acc,choices)
                    else
                      if is_choice iname
                      then
                        let tvconvs, pats, _, expr = toxml_choices ctxt.typmap 1 tt in
                        (acc,choices@[(tvconvs,name,iname,pats,expr,None,None)])
                      else
                        let tvconvs, pats, _, expr = make_toxml ctxt.typmap 1 tt in
                        ((acc@[tvconvs,name,iname,pats,expr,isel,mino,maxo]),choices)) ctxt.typmap ([],[]) in
  fprintf oc
    "\n\
let rec %s\n\n"
    (String.concat "\nand "
       (List.map
          (fun (c,n,ni,p,e,isel,mino,maxo) ->
             let cn = cn_prefix^"_"^ni in
             let cname, ls, ps, pe, le =
               if isel
               then cn, "[", (sprintf "WC.E ((WC.mkstag \"%s\"), (" n), "))", "]"
               else "", "", "", "", ""
             in
             match mino, maxo with
             | Some "0", Some "0" ->
                 sprintf "\
toxml_%s %s = function\n \
| _ -> []\n"
                   n (tvstr c)
             | Some "0", Some "1"
             | Some "0", None ->
                 sprintf "\
toxml_%s %s = function\n \
| (%s (Some %s)) ->\n \
%s%s%s%s%s\n \
| (%s None) -> []\n"
                   ni (tvstr c) cname (tvstr p) ls ps e pe le cname
             | Some "1", Some "1"
             | None, None ->
                 sprintf "\
toxml_%s %s = function\n \
| (%s %s) ->\n \
%s%s%s%s%s\n"
                   ni (tvstr c) cname (tvstr p) ls ps e pe le
             | _, _ ->
                 sprintf "\
toxml_%s %s = function\n \
| (%s []) -> []\n \
| (%s l) -> List.map (function %s -> %s%s%s) l\n"
                   ni (tvstr c) cname cname (tvstr p) ps e pe
          ) pes));
  fprintf oc "%s%s\n\n"
    (if choices <> [] then "and " else "")
    (String.concat "\nand "
       (List.map
          (fun (c,n,ni,p,e,mino,maxo) ->
             sprintf "toxml_%s %s = %s\n" n (tvstr c) e)
          choices))


(* End of XML output functions *)

(* XML input functions *)

let make_fromxml_const ai cte =
  let convfn, cname, cnt =
    match cte with
    | O.TypeString -> "","str",1
    | O.TypeInt -> "WC.fx \"int\" int_of_string","i",1
    | O.TypeInt64 -> "WC.fx \"int64\" Int64.of_string","i64",1
    | O.TypeFloat -> "WC.fx \"float\" float_of_string","f",1
    | O.TypeBool -> "WC.fx \"bool\" bool_of_string","b",1
    | O.TypeChar -> "(fun str -> str.[0])","c",1
    | O.TypeUnit -> "(fun u -> u)","()",0
  in
  let arg = cname^(if cnt > 0 then string_of_int ai else "") in
  arg, ai+cnt, convfn

let make_tvconv tv = "fromxml_"^(arg_of_tvn tv)

let rec make_fromxml tm ai = function
  | O.TypeVar tv ->
      eprintf "typevar: %s\n%!" tv;
      let arg = arg_of_tvn tv in
      let confn = sprintf "fromxml_%s" arg in
      [], [arg], ai, sprintf "(%s %s)" confn arg
  | O.TypeName ([], ["WC";"t_dateTime"]) ->
      let arg = "dT"^(string_of_int ai) in
      [], [arg], ai,
      (sprintf "(function [(WC.D %s)] -> (WC.fx \"dateTime\" WC.dateTime_of_string %s) | _ -> raise (WC.Wsdl2mlInputFailure \"Expected dateTime\"))" arg arg)
  | O.TypeName ([], ["WC";"t_byte"]) ->
      let arg = "byte"^(string_of_int ai) in
      [], [arg], ai,
      (sprintf "(function [(WC.D %s)] -> (WC.fx \"byte\" WC.byte_of_string %s) | _ -> raise (WC.Wsdl2mlInputFailure \"Expected byte\"))" arg arg)
  | O.TypeName ([tv], ["option"]) ->
      let tvconvs, args, ai, tpv = make_fromxml tm ai tv in
      tvconvs, args, ai, sprintf "%s" tpv
  | O.TypeName ([tv], ["list"]) ->
      let tvconvs, args, ai, tpv = make_fromxml tm ai tv in
      tvconvs, args, ai, sprintf "(%s)" tpv
  | O.TypeName (tvs, [tn]) ->
      (try
         let has_con, _isel, _name, iname, _, _, te = TypeMap.find (tv_names tvs,tn) tm in
         let arg = sprintf "v_%d" ai in
         let istv, tv = match te with O.TypeVar tv -> true, tv | _ -> false, "" in
         let tvs = tvs_of_te te in
         (*eprintf "tvs: %s\n%!" (String.concat "," tvs);*)
         let tvconv, tpv =
           if has_con
           then
             let tvconv = if tvs = [] then "" else make_tvconv (List.hd tvs) in
             (if tvconv <> "" then [tvconv] else []), sprintf "(fromxml_%s %s)" iname tvconv
           else
             if istv
             then
               let tvconv = "fromxml_"^(arg_of_tvn tv) in
               [tvconv], sprintf "%s" tvconv
             else [], sprintf "%s" arg
         in
         tvconv, [arg], ai+1, tpv
       with Not_found ->
         let tvconvs, args, ai, tpvs = make_fromxmls tm ai tvs in
         tvconvs, args, ai, sprintf "(%s %s)" tn (String.concat " " tpvs))
  | O.TypeName (tvs, tn) ->
      let tvconvs, args, ai, tpvs = make_fromxmls tm ai tvs in
      tvconvs, args, ai, sprintf "(%s (* arity:%d *) %s)" (make_type_name tn) (List.length tn) (String.concat " " tpvs)
  | O.TypeConst O.TypeString ->
      let arg, ai, convfn = make_fromxml_const ai O.TypeString in
      [], [arg], ai, (sprintf "(function [(WC.D %s)] -> %s | [] -> \"\" | _ -> raise (WC.Wsdl2mlInputFailure \"Expected const\"))"
                              arg arg)
  | O.TypeConst O.TypeUnit ->
      [], ["()"], ai, "(function [] -> () | _ -> raise (WC.Wsdl2mlInputFailure \"Expected unit\"))"
  | O.TypeConst cte ->
      let arg, ai, convfn = make_fromxml_const ai cte in
      [], [arg], ai, (sprintf "(function [(WC.D %s)] -> (%s %s) | _ -> raise (WC.Wsdl2mlInputFailure \"Expected const\"))"
                        arg convfn arg)
  | O.TypeTuple tes ->
      (match tes with
       | [] -> [], [], ai, "(function [] -> () | _ -> raise (WC.Wsdl2mlInputFailure \"Expected empty tuple\"))"
       | [te] -> make_fromxml tm ai te
       | tes ->
           let tvconvs, args, ai, tpvs = make_fromxmls tm ai tes in
           let _, targs = List.fold_left (fun (i,targs) _tpv -> (i+1,(targs@[sprintf "v_%d" i]))) (1,[]) tpvs in
           let tpvs = List.map2 (fun targ tpv -> sprintf "(%s sts)" tpv) targs tpvs in
           let f = sprintf "(function sts -> %s)" (String.sconcat ~left:"(" ~right:")" ", " tpvs) in
           (*eprintf "tvconvs: %s\n" (String.concat ", " tvconvs);
eprintf "tpvs: %s\n" (String.concat ", " tpvs);
eprintf "f: %s\n" f;*)
           tvconvs, args, ai, f)
  (*| 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_fromxmls tm ai tes =
  List.fold_left (fun (tvconvs,args,ai,tpvs) te ->
                    let tvconvs2, args2, ai, tpv = make_fromxml tm ai te in
                    (tvconvs@tvconvs2), (args@args2), ai, (tpvs@[tpv])) ([],[],ai,[]) tes

let fromxml_choices tm ai = function
  | O.TypeConstructor cl ->
      let tvconvs, args, ai, tpvs, ns =
        List.fold_left
          (fun (tvconvs,args,ai,tpvs,ns) (name,teo) ->
             match teo with
             | Some te ->
                 let tvconvs2, args2, ai, tpv = make_fromxml tm ai te in
                 let pre, num, n, idx = chpre name in (* <--- Won't work with type variables !!!! *)
                 let ni = n^idx in
                 (*eprintf "fromxml_choices: name=%s n=%s ni=%s\n%!" name n ni;*)
                 ((tvconvs@tvconvs2), (args@args2), ai,
                  (tpvs@[sprintf "[WC.E (((_,\"%s\"),_),_)] as sts -> (Ch%s_%s (%s %s sts))" n num ni tpv (tvstr tvconvs2)]),
                  (ns@[n]))
             | None ->
                 (eprintf "fromxml_choices: No constructor\n%!";
                  (tvconvs,args,ai,tpvs,ns))
          ) ([], [], ai, [], []) cl in
      let fail = sprintf "_ -> raise (WC.Wsdl2mlInputFailure \"Expected (%s)\")" (String.concat ", " ns) in
      tvconvs, args, ai, (sprintf "%s" (String.sconcat ~left:"(function\n " ~right:")" "\n | " (tpvs@[fail]))), ns
  | _ ->
      eprintf "fromxml_choices: not a TypeConstructor\n%!";
      [], [], ai, "<dongle>", []

let make_from_xml ctxt oc =
  fprintf oc "\n(* XML input functions *)\n\n";
  let pes, choices =
    TypeMap.fold (fun (_tvs,tn) (has_con,isel,name,iname,mino,maxo,tt) (acc,choices) ->
                    if not has_con || String.sub tn 0 (tnplen-1) <> tn_prefix || tn.[tnplen-1] <> '_'
                    then (acc,choices)
                    else
                      if is_choice iname
                      then
                        let tvconvs, pats, _, expr, ns = fromxml_choices ctxt.typmap 1 tt in
                        (acc,(choices@[(tvconvs,name,iname,pats,expr,ns)]))
                      else
                        let tvconvs, pats, _, expr = make_fromxml ctxt.typmap 1 tt in
                        ((acc@[tvconvs,name,iname,pats,expr,isel,mino,maxo]),choices)) ctxt.typmap ([],[])
  in
  fprintf oc
    "\
let rec %s\n\n"
    (String.concat "and "
       (List.map
          (fun (c,n,ni,p,e,isel,mino,maxo) ->
             let cn = cn_prefix^"_"^ni in
             let cname, ls, ps, pe, le, find, fail =
               if isel
               then (cn, "[", (sprintf "WC.E (((_,\"%s\"),_), (" n), "))", "]",
                     sprintf "(WC.find_name \"%s\" sts)" n,
                     sprintf " | _ -> raise (WC.Wsdl2mlInputFailure \"Expected %s\")\n" ni)
               else "", "", "", "", "", "sts", ""
             in
             match mino, maxo with
             | Some "0", Some "0" ->
                 let fail = sprintf "raise (WC.Wsdl2mlInputFailure \"%s has minOccurs,maxOccurs = 0,0\")" n in
                 sprintf "fromxml_%s %s = function (*0,0*)\n | [] -> None\n%s\n\n" ni (tvstr c) fail
             | Some "0", Some "1"
             | Some "0", None ->
                 let pat0 = sprintf "[]" in
                 let exp0 = sprintf "(%s None)" cname in
                 let pat1 = sprintf "%s%ssts%s%s" ls ps pe le in
                 let exp1 = sprintf "(%s (Some (%s sts)))" cname e in
                 sprintf "fromxml_%s %s sts = (function (*%s,%s*)\n | %s -> %s\n | %s -> %s\n%s) %s\n\n"
                         ni (tvstr c) (os mino) (os maxo) pat0 exp0 pat1 exp1 fail find
             | Some "1", Some "1"
             | None, None ->
                 let pat = sprintf "%s%ssts%s%s" ls ps pe le in
                 let exp = sprintf "(%s (%s sts))" cname e in
                 if isel
                 then sprintf "fromxml_%s %s sts = (function (*%s,%s*)\n | %s -> %s\n%s) %s\n\n"
                              ni (tvstr c) (os mino) (os maxo) pat exp fail find
                 else sprintf "fromxml_%s %s sts = %s\n\n" ni (tvstr c) exp
             | _, _ ->
                 let pat = sprintf "%ssts%s" ps pe in
                 let exp = sprintf "(%s sts)" e in
                 sprintf "fromxml_%s %s sts = (*%s,%s*)\n %s (List.map (function\n | %s -> %s\n%s) sts)\n\n"
                         ni (tvstr c) (os mino) (os maxo) cname pat exp fail)
          pes));
  fprintf oc "%s %s\n\n"
    (if choices <> [] then "and " else "")
    (String.concat "and "
       (List.map
          (fun (c,n,ni,p,e,ns) ->
             sprintf "fromxml_%s %s sts = %s\n (WC.find_names [%s] sts)\n"
                     n (tvstr c) e (String.concat "; " (List.map (fun s -> "\""^s^"\"") ns)))
          choices))

(* End of XML input functions *)

let zip2 l1 l2 =
  let rec aux = function
    | ([],[]) -> []
    | (h1::t1,h2::t2) -> (h1,h2)::aux (t1,t2)
    | _ -> raise (Failure "zip2: unequal lists")
  in
  aux (l1,l2)

let cmp_fst compare (s1,_) (s2,_) = compare s1 s2
let compare_tvtoxml tv1 tv2 = cmp_fst compare_tv tv1 tv2

let make_toxml_t ctxt oc =
  let tox_of_tv tv = sprintf "toxml_%s" (arg_of_tvn tv) in
  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
                        let toxmltvs = List.map tox_of_tv tvs in
                        tvs@tvs2, cons@[sprintf " | (`%s_%s v) -> toxml_%s %s v\n" cc_prefix name name (tvstr toxmltvs)])
      ctxt.typmap ([],[]) in
  let tvs = List.uniq ~cmp:String.compare (List.sort compare_tv tvs) in
  let toxmls = List.map tox_of_tv tvs in
  fprintf oc "\nlet toxml_t %s = function\n%s\n" (tvstr toxmls) (String.concat "" cons)

let make_fromxml_t ctxt oc =
  let fromx_of_tv tv = sprintf "fromxml_%s" (arg_of_tvn tv) in
  let typs =
    TypeMap.fold (fun (tvs,tn) (has_con,_isel,name,iname,_mino,_maxo,_tt) typs ->
                    let rec aux = function
                      | [] -> [(name,[(tvs,tn,has_con,_isel,name,iname,_mino,_maxo,_tt)])]
                      | (n,l)::rest ->
                          if n = name
                          then ((name,((tvs,tn,has_con,_isel,name,iname,_mino,_maxo,_tt)::l))::rest)
                          else (n,l)::(aux rest)
                    in
                    aux typs) ctxt.typmap []
  in
  let tvs, cons =
    List.fold_left
      (fun (tvs2,cons) (n,l) ->
         if is_choice n
         then (tvs2,cons)
         else
           let (_,ll) =
             List.partition
               (fun (tvs,tn,has_con,_isel,name,iname,_mino,_maxo,_tt) ->
                  not has_con || String.sub tn 0 (tnplen-1) <> tn_prefix || tn.[tnplen-1] <> '_') l
           in
           match ll with
           | [] -> (tvs2,cons)
           | [(tvs,tn,has_con,_isel,name,iname,_mino,_maxo,_tt)] ->
               let fromxmltvs = List.map fromx_of_tv tvs in
               tvs@tvs2, cons@[sprintf " | [WC.E (((_,\"%s\"),_),_)] -> (`%s_%s (fromxml_%s %s t))\n"
                                       name cc_prefix iname iname (tvstr fromxmltvs)]
           | _ ->
               let tvs3, cons3 =
                 List.fold_left
                   (fun (tvs3,cons3) (tvs,tn,has_con,_isel,name,iname,_mino,_maxo,_tt) ->
                      let fromxmltvs = List.map fromx_of_tv tvs in
                      tvs@tvs3, cons3@[
                        sprintf "try (`%s_%s (fromxml_%s %s t)) with WC.Wsdl2mlInputFailure _ ->\n "
                                cc_prefix iname iname (tvstr fromxmltvs)])
                   ([],[]) ll
               in
               let fail = sprintf "raise (WC.Wsdl2mlInputFailure \"fromxml_t: Expected %s\"))\n" n in
               tvs3@tvs2, cons@[
                 sprintf " | [WC.E (((_,\"%s\"),_),_)] ->\n (%s%s" n (String.concat "" cons3) fail
               ])
      ([],[]) typs
  in
  let tvs = List.uniq ~cmp:String.compare (List.sort compare_tv tvs) in
  let fromxmls = List.map fromx_of_tv tvs in
  fprintf oc "\nlet fromxml_t %s t = match t with\n%s" (tvstr fromxmls) (String.concat "" cons);
  fprintf oc " | [WC.E (((_,s),_),_)] -> raise (WC.Wsdl2mlInputFailure (\"fromxml_t: Unknown constructor \"^s))\n";
  fprintf oc " | _ -> raise (WC.Wsdl2mlInputFailure \"fromxml_t: Bad XML input\")\n\n"

let generate_debug_code oc =
  fprintf oc "\
let test (v,toxml,fromxml,name) =\n \
let vxml = toxml v in\n \
Printf.printf \"%%s XML = %%s\\n\" name (WC.string_of_tree (None,List.hd vxml));\n \
let v_ = fromxml vxml in\n \
Printf.printf \"%%s_good=%%b\\n\" name (v=v_)\n\
;;\n\
let toxml_anys = (WC.toxml_int,WC.toxml_bool,WC.toxml_int,WC.toxml_int,WC.toxml_int,WC.toxml_int,\n \
WC.toxml_int,WC.toxml_int,WC.toxml_int,WC.toxml_int,WC.toxml_int);;\n\
let fromxml_anys = (WC.fromxml_int,WC.fromxml_bool,WC.fromxml_int,WC.fromxml_int,WC.fromxml_int,WC.fromxml_int,\n \
WC.fromxml_int,WC.fromxml_int,WC.fromxml_int,WC.fromxml_int,WC.fromxml_int);;\n\
test ((make_Profile ~str:\"abc\" ()),toxml_Profile,fromxml_Profile,\"Profile\");;\n\
test ((make_BeginSession ~_Profile:\"abc\" ()),toxml_BeginSession,fromxml_BeginSession,\"BeginSession\");;\n\
test ((make_SubmitXml ~_Profile:\"abc\" ~a2:true ()),\n \
(toxml_SubmitXml (WC.toxml_int,WC.toxml_bool)),\n \
(fromxml_SubmitXml (WC.fromxml_int,WC.fromxml_bool)),\n \
\"SubmitXml\");;\n\
test ((make_MultiSubmitXml ~_Profile:\"abc\" ~a4:true ()),\n \
(toxml_MultiSubmitXml WC.toxml_bool),\n \
(fromxml_MultiSubmitXml WC.fromxml_bool),\n \
\"MultiSubmitXml\");;\n\n";
  if !collect
  then fprintf oc "\
let sxt = make_SubmitXml_t ~_Profile:\"abc\" ~a1:123 ~a2:true ();;\n\
test(sxt,(toxml_t toxml_anys),(fromxml_t fromxml_anys),\"SubmitXml_t\");;\n\
let msxt = make_MultiSubmitXml_t ~_Profile:\"abc\" ~a4:123 ();;\n\
test(msxt,(toxml_t toxml_anys),(fromxml_t fromxml_anys),\"MultiSubmitXml_t\");;\n\n"

let extfile filename suffix ext =
  (Tools.add_suffix (if Filename.check_suffix filename ".wsdl"
                     then Filename.chop_suffix filename ".wsdl"
                     else if Filename.check_suffix filename ".xsd"
                     then Filename.chop_suffix filename ".xsd"
                     else filename) suffix)^ext

let files = ref ([]:string list)
let it_ref = ref Idx

let rec get_names trees =
  let aux acc = function
    | WC.E (((_,("complexType"|"element")),atts),trees) ->
        (match WC.find_att ("","name") atts with
         | Some name -> name::acc
         | None -> acc)
    | _ -> acc
  in
  List.fold_left (fun acc tree -> WC.fold_tree aux acc tree) [] trees

let rec get_definitions ctxt oc trees =
  let els = List.filter (function | WC.E (((_,"definitions"),_),_) -> true | _ -> false) trees in
  dprintf "%d definitions\n%!" (List.length els);
  List.fold_left (fun (ctxt,acc) el -> let ctxt, els = get_definition ctxt oc el in (ctxt,acc@els)) (ctxt,[]) els

and get_definition ctxt oc = function
  | WC.E (((_,"definitions"),atts),trees) ->
      let _msgs = WC.find_name "message" trees in
      let _portTypes = WC.find_name "portType" trees in
      let _bindings = WC.find_name "binding" trees in
      let _services = WC.find_name "service" trees in
      dprintf "%d messages\n%d portTypes\n%d bindings\n%d services\n%!"
        (List.length _msgs) (List.length _portTypes) (List.length _bindings) (List.length _services);
      List.fold_left (fun (ctxt,acc) _service ->
                        let ctxt, a = get_service ctxt oc (_msgs,_portTypes,_bindings) _service in
                        (ctxt,acc@a)) (ctxt,[]) _services
  | WC.E (((_,n),atts),trees) -> eprintf "Not definitions: %s\n%!" n; ctxt, []
  | _ -> assert false

and get_service ctxt oc mpb = function
  | WC.E (((_,"service"),atts),trees) ->
      (match WC.find_att ("","name") atts with
       | Some name ->
           dprintf "service: name=%s\n%!" name;
           fprintf oc "(* Associated service: %s *)\n" name;
           ctxt, [(name,atts,trees,mpb)]
       | None -> ctxt, [("noname",atts,trees,mpb)])
  | WC.E (((_,n),_),_) -> eprintf "Not service: %s\n%!" n; ctxt, []
  | _ -> assert false

let find_elname elname name =
  List.find_opt (function
                 | (WC.E (((_,ename),atts),_)) when ename = elname ->
                     (match WC.find_att ("","name") atts with
                      | Some _name -> name = _name
                      | None -> false)
                 | _ -> false)

let find_message name (m,_,_) = find_elname "message" name m
let find_portType name (_,p,_) = find_elname "portType" name p
let find_binding name (_,_,b) = find_elname "binding" name b

let find_op_pt name = function
  | WC.E (((_,"portType"),atts),trees) -> find_elname "operation" name trees
  | WC.E (((_,n),_),_) -> eprintf "Not portType: %s\n%!" n; None
  | _ -> assert false

let find_el_att elname attname trees =
  match WC.find_name elname trees with
  | [WC.E (((_,ename),atts),trees)] when ename = elname ->
      WC.find_att ("",attname) atts
  | _ -> None

let find_address = find_el_att "address" "location"

let find_io sc = function
  | WC.E (((_,"operation"),atts),trees) ->
      (match WC.find_name "input" trees, WC.find_name "output" trees with
       | (([_] as input), ([_] as output)) ->
           (find_el_att "input" "message" input, find_el_att "output" "message" output)
       | _ -> None, None)
  | WC.E (((_,n),_),_) -> eprintf "Not operation: %s\n%!" n; None, None
  | _ -> assert false

let find_element (typmap,phargassoc) name =
  List.find_opt (fun ((_,_),(_,_,_name,_,_,_,_)) -> _name = name) typmap,
  List.assoc_opt name phargassoc

let get_msg_el ctxt sc name =
  match Str.split recolon name with
  | ["tns";elname]
  | [elname] ->
      let t_opt, pha_opt = find_element ctxt elname in
      (match t_opt, pha_opt with
       | (Some ((_tvs,_),(_has_con,_isel,_name,_iname,_,_,_te)), Some phargs) as type_opt ->
           dprintf "type:%s %s\n%!" _name phargs;
           fprintf sc "(* Type: %s %s *)\n\n" _name phargs;
           type_opt
       | _ ->
           eprintf "missing type %s\n%!" elname;
           fprintf sc "(* Missing type %s *)\n" elname;
           None, None)
  | _ ->
      fprintf sc "(* Element has weird name %s *)\n" name; None, None

let get_part ctxt sc = function
  | WC.E (((_,"part"),atts),trees) ->
      (match WC.find_att ("","name") atts with
       | Some partname ->
           dprintf "part: %s\n%!" partname;
           fprintf sc "(* Part: %s *)\n" partname;
           (match WC.find_att ("","element") atts with
            | Some elementname ->
                get_msg_el ctxt sc elementname
            | None ->
                fprintf sc "(* Part has no element *)\n"; None, None)
       | None ->
           fprintf sc "(* Part has no name *)\n"; None, None)
  | WC.E (((_,n),_),_) -> eprintf "Not part: %s\n%!" n; None, None
  | _ -> assert false

let get_parts ctxt sc trees = List.map (get_part ctxt sc) (WC.find_name "part" trees)

let make_message name ctxt sc mpb =
  match Str.split recolon name with
  | ["tns";msgname]
  | [msgname] ->
      (match find_message msgname mpb with
       | Some msg ->
           (match msg with
            | WC.E (((_,"message"),atts),trees) ->
                (match WC.find_att ("","name") atts with
                 | Some msgname ->
                     dprintf "message: %s\n%!" msgname;
                     fprintf sc "(* Message: %s *)\n" msgname;
                     get_parts ctxt sc trees
                 | None ->
                     fprintf sc "(* Message has no name *)\n"; [])
            | WC.E (((_,n),_),_) -> eprintf "Not message: %s\n%!" n; []
            | _ -> assert false)
       | None ->
           eprintf "missing message %s\n%!" msgname;
           fprintf sc "(* Missing message %s *)\n" msgname;
           [])
  | _ ->
      fprintf sc "(* Message has weird name %s *)\n" name; []

let make_aws_request sc opname = function
  | [], _
  | _, [] ->
      eprintf "make_aws_request: missing messages\n%!"
  | [Some ((_,_),(_,_,iname,_,_,_,_)), Some iparams], [Some ((_,_),(_,_,oname,_,_,_,_)), _] ->
      dprintf "make_aws_request: iname=%s oname=%s iparams=%s\n%!" iname oname iparams;
      fprintf sc
"let _%s aws %s ?expires cont err_cont =\n \
let params = Ec2types.ph_%s %s in\n \
AmazonEC2.request_aws aws \"%s\" Ec2types.fromxml_%s params ?expires cont err_cont\n\n"
        opname iparams iname iparams oname oname
  | _ -> eprintf "make_aws_request: Can only handle single parts\n%!"

let make_operation ctxt sc mpb typename portType = function
  | WC.E (((_,"operation"),atts),trees) ->
      (match WC.find_att ("","name") atts with
       | Some opname ->
           dprintf "operation: %s\n%!" opname;
           fprintf sc "(* Operation: %s *)\n\n" opname;
           (match find_op_pt opname portType with
            | Some ptop ->
                (match find_io sc ptop with
                 | (Some input, Some output) ->
                     dprintf "input message: %s\noutput message: %s\n%!" input output;
                     make_aws_request sc opname (make_message input ctxt sc mpb, make_message output ctxt sc mpb)
                 | _ ->
                     eprintf "operation %s missing inputs/outputs\n%!" opname;
                     fprintf sc "(* Operation %s missing inputs/outputs *)\n" opname)
            | None ->
                eprintf "cannot find operation %s\n%!" opname;
                fprintf sc "(* Type %s missing operation %s *)\n" typename opname)
       | None ->
           fprintf sc "(* Operation has no name *)\n")
  | WC.E (((_,n),_),_) -> eprintf "Not operation: %s\n%!" n; ()
  | _ -> assert false

let make_bindings ctxt sc mpb bindname = function
  | WC.E (((_,"binding"),atts),trees) ->
      (match WC.find_att ("","type") atts with
       | Some _type ->
           (match Str.split recolon _type with
            | ["tns";typename]
            | [typename] ->
                dprintf "type: %s\n%!" typename;
                fprintf sc "(* Type: %s *)\n" typename;
                (match find_portType typename mpb with
                 | Some portType ->
                     let operations = WC.find_name "operation" trees in
                     dprintf "%d operations\n%!" (List.length operations);
                     List.iter (make_operation ctxt sc mpb typename portType) (List.rev operations)
                 | None ->
                     eprintf "cannot find portType %s\n%!" typename;
                     fprintf sc "(* Binding %s missing portType %s *)\n" bindname typename)
            | _ ->
                fprintf sc "(* Binding %s has weird type %s *)\n" bindname _type)
       | None ->
           fprintf sc "(* Binding %s has no type *)\n" bindname)
  | WC.E (((_,n),_),_) -> eprintf "Not binding: %s\n%!" n; ()
  | _ -> assert false

let get_port ctxt sc mpb = function
  | WC.E (((_,"port"),atts),trees) ->
      (match WC.find_att ("","name") atts with
       | Some portname ->
           let address_opt = find_address trees in
           dprintf "port: name=%s address=%s\n%!" portname (os address_opt);
           fprintf sc "(* Port: %s Address:%s *)\n" portname (os address_opt);
           if Option.is_some address_opt then fprintf sc "let port_%s = \"%s\"\n\n" portname (Option.get address_opt);
           (match WC.find_att ("","binding") atts with
            | Some bind ->
                (match Str.split recolon bind with
                 | ["tns";bindname]
                 | [bindname] ->
                     dprintf "binding: %s\n%!" bindname;
                     fprintf sc "(* Binding: %s *)\n" bindname;
                     (match find_binding bindname mpb with
                      | Some binding ->
                          make_bindings ctxt sc mpb bindname binding
                      | None ->
                          eprintf "cannot find binding %s\n%!" bindname;
                          fprintf sc "(* Port %s missing binding %s *)\n" portname bindname)
                 | _ ->
                     fprintf sc "(* Port %s has weird binding %s *)\n" portname bind)
            | None ->
                fprintf sc "(* Port %s has no binding *)\n" portname)
       | None ->
           fprintf sc "(* Port has no name *)\n")
  | WC.E (((_,n),_),_) -> eprintf "Not port: %s\n%!" n; ()
  | _ -> assert false

let make_service ctxt phargmap filename (name,atts,trees,mpb) =
  let ctxt = (TypeMap.to_list ctxt.typmap, phargmap) in
  let sc = open_out (extfile filename ("service"^name) ".ml") in
  let tim = Time.localtime (Time.now ()) in
  fprintf sc "(* Translated from %s\n * Date: %s %s\n *)\n\n(* Service %s *)\n\n"
             filename (Date.date2 tim) (Date.time tim) name;
  let _ports = WC.find_name "port" trees in
  dprintf "%d ports\n%!" (List.length _ports);
  List.iter (get_port ctxt sc mpb) _ports;
  close_out sc(*;
let l = List.map (function ((_tvs,_tn),(_has_con,_isel,_name,_iname,_mino,_maxo,_te)) -> _name) ctxt in
dprintf "ctxt: [%s]\n%!" (String.concat "; " l)*)

let open_file_hdr filename suffix ext modules desc =
  let file = extfile filename suffix ext in
  if !verbose then printf "Opened file: %s\n" file;
  let oc = open_out file in
  let tim = Time.localtime (Time.now ()) in
  fprintf oc "(* Translated from %s\n * Date: %s %s\n *)\n\n" filename (Date.date2 tim) (Date.time tim);
  if modules <> "" then fprintf oc "%s\n" modules;
  fprintf oc "(* %s *)\n\n" desc;
  oc

let _WC = "module WC = Wsdl2mlCommon\n"

let translate_file debug filename =
  let tree = ("tns", WC.get_tree_filename filename) in
  if !verbose then printf "Read file: %s\n" filename;
  let trees = (*resolve_imports tree*) [tree] in (* This doesn't really work for the moment (Http_client) *)
  let _types = WC.fold_trees find_types_ff [] trees in
  if _types = [] then failwith (sprintf "wsdl2ml: No types defined in %s%!" filename);
  let names = get_names _types in
  let tnames = StringSet.add_list names StringSet.empty in
  (*eprintf "names=[%s]\n%!" (String.concat ", " names);*)
  (*let oc = open_out (extfile filename "types" ".ml") in*)
  let oc = open_file_hdr filename "types" ".ml" _WC "Basic types" in
  (*let tc = if !mlidl then open_out (extfile filename "types" ".mlidl") else oc in*)
  let tc = if !mlidl then open_file_hdr filename "types" ".mlidl" "" "IDL file" else oc in
  let ctxt = { first = true;
               cn = 1;
               tnames = tnames;
               ctmap = StringMap.empty;
               typmap = TypeMap.empty;
               it = (!it_ref);
               ind = 0;
               type_t = "<missing>";
             } in
  let ctxt = List.fold_left (fun ctxt _type -> let ctxt, _ = get_schemas ctxt tc _type in ctxt) ctxt _types in
  let ctxt = if !collect then make_t ctxt oc else ctxt in
  if !mlidl then close_out tc;
  if !verbose then printf "Converted basic types.\n";
  make_conveniences ctxt oc;
  if !verbose then printf "Generated convenience functions.\n";
  let phargmap =
    if !post_headers
    then (let phargmap = make_phs ctxt oc in
          if !verbose then printf "Generated post header functions.\n";
          phargmap)
    else []
  in
  make_to_xml ctxt oc;
  if !collect then make_toxml_t ctxt oc;
  if !verbose then printf "Generated XML output functions.\n";
  make_from_xml ctxt oc;
  if !collect then make_fromxml_t ctxt oc;
  if !verbose then printf "Generated XML input functions.\n";
  if debug then generate_debug_code oc;
  let _definitions = WC.find_trees (WC.is_tree_name "definitions") trees in
  let ctxt, svcs = get_definitions ctxt oc _definitions in
  List.iter (make_service ctxt phargmap filename) svcs;
  close_out oc

let usage = "wsdl2ml {options} <wsdl file>\n"
let _ =
  Arg.parse
    [("--debug-name", (Arg.String (fun s -> myname := s)), "<string>\tPrint debug info for named type.");
     ("--collect", (Arg.Bool (fun b -> collect := b)), (sprintf "<bool>\tAdd collect type (default: %b)." !collect));
     ("--post-headers", (Arg.Bool (fun b -> post_headers := b)), (sprintf "<bool>\tAdd POST header functions (default: %b)."
                                                                          !post_headers));
     ("--mlidl", (Arg.Bool (fun b -> mlidl := b)), (sprintf "<bool>\tOutput types as MLIDL file (default: %b)." !mlidl));
     ("-g", (Arg.Unit (fun () -> debug := true)), "Debug mode.");
     ("-v", (Arg.Unit (fun () -> verbose := true)), "Verbose mode.");
    ]
    (fun str -> files := (!files)@[str])
    (usage^"Options:");
  if !files = []
  then printf "%s\n" usage
  else List.iter (translate_file false) (!files)
Something went wrong with that request. Please try again.