diff --git a/dune-project b/dune-project index 6b1228397..546b268db 100644 --- a/dune-project +++ b/dune-project @@ -43,7 +43,9 @@ (merlin-extend (>= "0.6")) fix - ppx_derivers)) + ppx_derivers + (ppxlib + (>= "0.28.0")))) (package (name rtop) diff --git a/esy.json b/esy.json index c3cf11de6..f0906fe68 100644 --- a/esy.json +++ b/esy.json @@ -12,6 +12,7 @@ "@opam/merlin-extend": " >= 0.6", "@opam/ocamlfind": "1.9.5", "@opam/ppx_derivers": "< 2.0.0", + "@opam/ppxlib": "> 0.28.x", "@opam/utop": " >= 1.17.0", "ocaml": " >= 4.3.0 < 4.15.0" }, diff --git a/esy.lock/index.json b/esy.lock/index.json index b811aa7b4..e16b24647 100644 --- a/esy.lock/index.json +++ b/esy.lock/index.json @@ -1,5 +1,5 @@ { - "checksum": "541ef021a71d9d8bce474b1d40a99f0b", + "checksum": "c3c0ec4dc1dab9c4069b9ff27b904076", "root": "reason-cli@link-dev:./esy.json", "node": { "reason-cli@link-dev:./esy.json": { @@ -9,14 +9,15 @@ "source": { "type": "link-dev", "path": ".", "manifest": "esy.json" }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/utop@opam:2.11.0@bd245e47", + "ocaml@4.14.0@d41d8cd9", "@opam/utop@opam:2.12.0@41cf0331", + "@opam/ppxlib@opam:0.29.1@8414c948", "@opam/ppx_derivers@opam:1.2.1@e2cbad12", "@opam/ocamlfind@opam:1.9.5@e83abf74", "@opam/merlin-extend@opam:0.6.1@7d979feb", - "@opam/menhir@opam:20220210@ff5ea9a7", + "@opam/menhir@opam:20230415@ce1c9ac7", "@opam/fix@opam:20220121@17b9a1a4", - "@opam/dune-build-info@opam:3.7.0@ce68449d", - "@opam/dune@opam:3.7.0@95218dc4" + "@opam/dune-build-info@opam:3.7.1@adf0d411", + "@opam/dune@opam:3.7.1@40db2f22" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/odoc@opam:2.2.0@020767ad", @@ -59,14 +60,14 @@ "@opam/uuseg@opam:15.0.0@14085231", "@opam/uucp@opam:15.0.0@55460339", "@opam/uchar@opam:0.0.2@aedf91f9", "@opam/result@opam:1.5@1c6a6533", "@opam/react@opam:1.2.2@e0f4480e", - "@opam/dune@opam:3.7.0@95218dc4", "@esy-ocaml/substs@0.0.1@d41d8cd9" + "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/uutf@opam:1.0.3@47c95a18", "@opam/uuseg@opam:15.0.0@14085231", "@opam/uucp@opam:15.0.0@55460339", "@opam/uchar@opam:0.0.2@aedf91f9", "@opam/result@opam:1.5@1c6a6533", "@opam/react@opam:1.2.2@e0f4480e", - "@opam/dune@opam:3.7.0@95218dc4" + "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/yojson@opam:2.0.2@eb65f292": { @@ -88,37 +89,37 @@ "overrides": [], "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/seq@opam:base@d8d7de1d", - "@opam/dune@opam:3.7.0@95218dc4", "@opam/cppo@opam:1.6.9@db929a12", + "@opam/dune@opam:3.7.1@40db2f22", "@opam/cppo@opam:1.6.9@db929a12", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/seq@opam:base@d8d7de1d", - "@opam/dune@opam:3.7.0@95218dc4" + "@opam/dune@opam:3.7.1@40db2f22" ] }, - "@opam/xdg@opam:3.7.0@449d6490": { - "id": "@opam/xdg@opam:3.7.0@449d6490", + "@opam/xdg@opam:3.7.1@387cb889": { + "id": "@opam/xdg@opam:3.7.1@387cb889", "name": "@opam/xdg", - "version": "opam:3.7.0", + "version": "opam:3.7.1", "source": { "type": "install", "source": [ - "archive:https://opam.ocaml.org/cache/sha256/e2/e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8#sha256:e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8", - "archive:https://github.com/ocaml/dune/releases/download/3.7.0/dune-3.7.0.tbz#sha256:e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8" + "archive:https://opam.ocaml.org/cache/sha256/ad/adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3#sha256:adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3", + "archive:https://github.com/ocaml/dune/releases/download/3.7.1/dune-3.7.1.tbz#sha256:adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3" ], "opam": { "name": "xdg", - "version": "3.7.0", - "path": "esy.lock/opam/xdg.3.7.0" + "version": "3.7.1", + "path": "esy.lock/opam/xdg.3.7.1" } }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/uutf@opam:1.0.3@47c95a18": { @@ -142,7 +143,7 @@ "ocaml@4.14.0@d41d8cd9", "@opam/topkg@opam:1.0.7@7ee47d76", "@opam/ocamlfind@opam:1.9.5@e83abf74", "@opam/ocamlbuild@opam:0.14.2@c6163b28", - "@opam/cmdliner@opam:1.1.1@03763729", + "@opam/cmdliner@opam:1.2.0@b0c6143c", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9" ] @@ -169,7 +170,7 @@ "@opam/uucp@opam:15.0.0@55460339", "@opam/topkg@opam:1.0.7@7ee47d76", "@opam/ocamlfind@opam:1.9.5@e83abf74", "@opam/ocamlbuild@opam:0.14.2@c6163b28", - "@opam/cmdliner@opam:1.1.1@03763729", + "@opam/cmdliner@opam:1.2.0@b0c6143c", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ @@ -198,25 +199,25 @@ "@opam/topkg@opam:1.0.7@7ee47d76", "@opam/ocamlfind@opam:1.9.5@e83abf74", "@opam/ocamlbuild@opam:0.14.2@c6163b28", - "@opam/cmdliner@opam:1.1.1@03763729", + "@opam/cmdliner@opam:1.2.0@b0c6143c", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9" ] }, - "@opam/utop@opam:2.11.0@bd245e47": { - "id": "@opam/utop@opam:2.11.0@bd245e47", + "@opam/utop@opam:2.12.0@41cf0331": { + "id": "@opam/utop@opam:2.12.0@41cf0331", "name": "@opam/utop", - "version": "opam:2.11.0", + "version": "opam:2.12.0", "source": { "type": "install", "source": [ - "archive:https://opam.ocaml.org/cache/sha256/69/6937c6c672913ac3b875341ac4a205c7561d01cd8ac8f47cfb35d3bc0e762170#sha256:6937c6c672913ac3b875341ac4a205c7561d01cd8ac8f47cfb35d3bc0e762170", - "archive:https://github.com/ocaml-community/utop/releases/download/2.11.0/utop-2.11.0.tbz#sha256:6937c6c672913ac3b875341ac4a205c7561d01cd8ac8f47cfb35d3bc0e762170" + "archive:https://opam.ocaml.org/cache/sha256/ad/ad19c859a783bec573cd91e810c54d0e6b70f339d0a4fed55ec672ae408aa1ea#sha256:ad19c859a783bec573cd91e810c54d0e6b70f339d0a4fed55ec672ae408aa1ea", + "archive:https://github.com/ocaml-community/utop/releases/download/2.12.0/utop-2.12.0.tbz#sha256:ad19c859a783bec573cd91e810c54d0e6b70f339d0a4fed55ec672ae408aa1ea" ], "opam": { "name": "utop", - "version": "2.11.0", - "path": "esy.lock/opam/utop.2.11.0" + "version": "2.12.0", + "path": "esy.lock/opam/utop.2.12.0" } }, "overrides": [], @@ -227,7 +228,7 @@ "@opam/lwt_react@opam:1.2.0@4253a145", "@opam/lwt@opam:5.6.1@2a9902ab", "@opam/logs@opam:0.7.0@46a3dffc", "@opam/lambda-term@opam:3.3.1@ee145aff", - "@opam/dune@opam:3.7.0@95218dc4", "@opam/cppo@opam:1.6.9@db929a12", + "@opam/dune@opam:3.7.1@40db2f22", "@opam/cppo@opam:1.6.9@db929a12", "@opam/base-unix@opam:base@87d0b2eb", "@opam/base-threads@opam:base@36803084", "@esy-ocaml/substs@0.0.1@d41d8cd9" @@ -239,7 +240,7 @@ "@opam/lwt_react@opam:1.2.0@4253a145", "@opam/lwt@opam:5.6.1@2a9902ab", "@opam/logs@opam:0.7.0@46a3dffc", "@opam/lambda-term@opam:3.3.1@ee145aff", - "@opam/dune@opam:3.7.0@95218dc4", + "@opam/dune@opam:3.7.1@40db2f22", "@opam/base-unix@opam:base@87d0b2eb", "@opam/base-threads@opam:base@36803084" ] @@ -292,12 +293,12 @@ "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/uutf@opam:1.0.3@47c95a18", "@opam/seq@opam:base@d8d7de1d", "@opam/re@opam:1.10.4@c4910ba6", - "@opam/dune@opam:3.7.0@95218dc4", "@esy-ocaml/substs@0.0.1@d41d8cd9" + "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/uutf@opam:1.0.3@47c95a18", "@opam/seq@opam:base@d8d7de1d", "@opam/re@opam:1.10.4@c4910ba6", - "@opam/dune@opam:3.7.0@95218dc4" + "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/trie@opam:1.0.0@f4e510e2": { @@ -318,11 +319,11 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/topkg@opam:1.0.7@7ee47d76": { @@ -371,7 +372,7 @@ "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/pp@opam:1.1.2@89ad03b5", "@opam/ordering@opam:3.6.2@37bc3093", - "@opam/dyn@opam:3.6.2@38120dfc", "@opam/dune@opam:3.7.0@95218dc4", + "@opam/dyn@opam:3.6.2@38120dfc", "@opam/dune@opam:3.7.1@40db2f22", "@opam/csexp@opam:1.5.1@8a8fb3a7", "@opam/base-unix@opam:base@87d0b2eb", "@esy-ocaml/substs@0.0.1@d41d8cd9" @@ -379,11 +380,36 @@ "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/pp@opam:1.1.2@89ad03b5", "@opam/ordering@opam:3.6.2@37bc3093", - "@opam/dyn@opam:3.6.2@38120dfc", "@opam/dune@opam:3.7.0@95218dc4", + "@opam/dyn@opam:3.6.2@38120dfc", "@opam/dune@opam:3.7.1@40db2f22", "@opam/csexp@opam:1.5.1@8a8fb3a7", "@opam/base-unix@opam:base@87d0b2eb" ] }, + "@opam/stdlib-shims@opam:0.3.0@72c7bc98": { + "id": "@opam/stdlib-shims@opam:0.3.0@72c7bc98", + "name": "@opam/stdlib-shims", + "version": "opam:0.3.0", + "source": { + "type": "install", + "source": [ + "archive:https://opam.ocaml.org/cache/sha256/ba/babf72d3917b86f707885f0c5528e36c63fccb698f4b46cf2bab5c7ccdd6d84a#sha256:babf72d3917b86f707885f0c5528e36c63fccb698f4b46cf2bab5c7ccdd6d84a", + "archive:https://github.com/ocaml/stdlib-shims/releases/download/0.3.0/stdlib-shims-0.3.0.tbz#sha256:babf72d3917b86f707885f0c5528e36c63fccb698f4b46cf2bab5c7ccdd6d84a" + ], + "opam": { + "name": "stdlib-shims", + "version": "0.3.0", + "path": "esy.lock/opam/stdlib-shims.0.3.0" + } + }, + "overrides": [], + "dependencies": [ + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", + "@esy-ocaml/substs@0.0.1@d41d8cd9" + ], + "devDependencies": [ + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" + ] + }, "@opam/spawn@opam:v0.15.1@85e9d6f1": { "id": "@opam/spawn@opam:v0.15.1@85e9d6f1", "name": "@opam/spawn", @@ -402,11 +428,36 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" + ] + }, + "@opam/sexplib0@opam:v0.15.1@51111c0c": { + "id": "@opam/sexplib0@opam:v0.15.1@51111c0c", + "name": "@opam/sexplib0", + "version": "opam:v0.15.1", + "source": { + "type": "install", + "source": [ + "archive:https://opam.ocaml.org/cache/md5/ab/ab8fd6273f35a792cad48cbb3024a7f9#md5:ab8fd6273f35a792cad48cbb3024a7f9", + "archive:https://github.com/janestreet/sexplib0/archive/refs/tags/v0.15.1.tar.gz#md5:ab8fd6273f35a792cad48cbb3024a7f9" + ], + "opam": { + "name": "sexplib0", + "version": "v0.15.1", + "path": "esy.lock/opam/sexplib0.v0.15.1" + } + }, + "overrides": [], + "dependencies": [ + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", + "@esy-ocaml/substs@0.0.1@d41d8cd9" + ], + "devDependencies": [ + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/seq@opam:base@d8d7de1d": { @@ -446,11 +497,11 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/react@opam:1.2.2@e0f4480e": { @@ -497,11 +548,43 @@ "overrides": [], "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/seq@opam:base@d8d7de1d", - "@opam/dune@opam:3.7.0@95218dc4", "@esy-ocaml/substs@0.0.1@d41d8cd9" + "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/seq@opam:base@d8d7de1d", - "@opam/dune@opam:3.7.0@95218dc4" + "@opam/dune@opam:3.7.1@40db2f22" + ] + }, + "@opam/ppxlib@opam:0.29.1@8414c948": { + "id": "@opam/ppxlib@opam:0.29.1@8414c948", + "name": "@opam/ppxlib", + "version": "opam:0.29.1", + "source": { + "type": "install", + "source": [ + "archive:https://opam.ocaml.org/cache/sha256/c8/c8ea8c8770414fdba6612e7f2d814b21a493daa974ea862a90c8e6c766e5dd79#sha256:c8ea8c8770414fdba6612e7f2d814b21a493daa974ea862a90c8e6c766e5dd79", + "archive:https://github.com/ocaml-ppx/ppxlib/releases/download/0.29.1/ppxlib-0.29.1.tbz#sha256:c8ea8c8770414fdba6612e7f2d814b21a493daa974ea862a90c8e6c766e5dd79" + ], + "opam": { + "name": "ppxlib", + "version": "0.29.1", + "path": "esy.lock/opam/ppxlib.0.29.1" + } + }, + "overrides": [], + "dependencies": [ + "ocaml@4.14.0@d41d8cd9", "@opam/stdlib-shims@opam:0.3.0@72c7bc98", + "@opam/sexplib0@opam:v0.15.1@51111c0c", + "@opam/ppx_derivers@opam:1.2.1@e2cbad12", + "@opam/ocaml-compiler-libs@opam:v0.12.4@41979882", + "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" + ], + "devDependencies": [ + "ocaml@4.14.0@d41d8cd9", "@opam/stdlib-shims@opam:0.3.0@72c7bc98", + "@opam/sexplib0@opam:v0.15.1@51111c0c", + "@opam/ppx_derivers@opam:1.2.1@e2cbad12", + "@opam/ocaml-compiler-libs@opam:v0.12.4@41979882", + "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/ppx_yojson_conv_lib@opam:v0.15.0@773058a7": { @@ -523,11 +606,11 @@ "overrides": [], "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/yojson@opam:2.0.2@eb65f292", - "@opam/dune@opam:3.7.0@95218dc4", "@esy-ocaml/substs@0.0.1@d41d8cd9" + "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/yojson@opam:2.0.2@eb65f292", - "@opam/dune@opam:3.7.0@95218dc4" + "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/ppx_derivers@opam:1.2.1@e2cbad12": { @@ -548,11 +631,11 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/pp@opam:1.1.2@89ad03b5": { @@ -573,11 +656,11 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/ordering@opam:3.6.2@37bc3093": { @@ -598,11 +681,11 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/omd@opam:1.3.2@511d53d2": { @@ -623,13 +706,13 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@opam/base-bytes@opam:base@19d0c2ff", "@opam/base-bigarray@opam:base@b03491b0", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@opam/base-bytes@opam:base@19d0c2ff", "@opam/base-bigarray@opam:base@b03491b0" ] @@ -653,14 +736,14 @@ "overrides": [], "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/result@opam:1.5@1c6a6533", - "@opam/dune@opam:3.7.0@95218dc4", + "@opam/dune@opam:3.7.1@40db2f22", "@opam/camlp-streams@opam:5.0.1@daaa0f94", "@opam/astring@opam:0.8.5@1300cee8", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/result@opam:1.5@1c6a6533", - "@opam/dune@opam:3.7.0@95218dc4", + "@opam/dune@opam:3.7.1@40db2f22", "@opam/camlp-streams@opam:5.0.1@daaa0f94", "@opam/astring@opam:0.8.5@1300cee8" ] @@ -687,8 +770,8 @@ "@opam/result@opam:1.5@1c6a6533", "@opam/odoc-parser@opam:2.0.0@a08011a0", "@opam/fpath@opam:0.7.3@674d8125", "@opam/fmt@opam:0.9.0@87213963", - "@opam/dune@opam:3.7.0@95218dc4", "@opam/cppo@opam:1.6.9@db929a12", - "@opam/cmdliner@opam:1.1.1@03763729", + "@opam/dune@opam:3.7.1@40db2f22", "@opam/cppo@opam:1.6.9@db929a12", + "@opam/cmdliner@opam:1.2.0@b0c6143c", "@opam/astring@opam:0.8.5@1300cee8", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], @@ -697,8 +780,8 @@ "@opam/result@opam:1.5@1c6a6533", "@opam/odoc-parser@opam:2.0.0@a08011a0", "@opam/fpath@opam:0.7.3@674d8125", "@opam/fmt@opam:0.9.0@87213963", - "@opam/dune@opam:3.7.0@95218dc4", - "@opam/cmdliner@opam:1.1.1@03763729", + "@opam/dune@opam:3.7.1@40db2f22", + "@opam/cmdliner@opam:1.2.0@b0c6143c", "@opam/astring@opam:0.8.5@1300cee8" ] }, @@ -720,11 +803,11 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/ocplib-endian@opam:1.2@008dc942": { @@ -745,13 +828,13 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@opam/cppo@opam:1.6.9@db929a12", "@opam/base-bytes@opam:base@19d0c2ff", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@opam/base-bytes@opam:base@19d0c2ff" ] }, @@ -773,11 +856,11 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@opam/csexp@opam:1.5.1@8a8fb3a7", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@opam/csexp@opam:1.5.1@8a8fb3a7" ] }, @@ -827,11 +910,11 @@ "overrides": [], "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/dyn@opam:3.6.2@38120dfc", - "@opam/dune@opam:3.7.0@95218dc4", "@esy-ocaml/substs@0.0.1@d41d8cd9" + "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/dyn@opam:3.6.2@38120dfc", - "@opam/dune@opam:3.7.0@95218dc4" + "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/ocamlbuild@opam:0.14.2@c6163b28": { @@ -880,7 +963,7 @@ "overrides": [], "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/yojson@opam:2.0.2@eb65f292", - "@opam/xdg@opam:3.7.0@449d6490", "@opam/uutf@opam:1.0.3@47c95a18", + "@opam/xdg@opam:3.7.1@387cb889", "@opam/uutf@opam:1.0.3@47c95a18", "@opam/stdune@opam:3.6.2@47d75c4b", "@opam/spawn@opam:v0.15.1@85e9d6f1", "@opam/re@opam:1.10.4@c4910ba6", "@opam/ppx_yojson_conv_lib@opam:v0.15.0@773058a7", @@ -891,14 +974,14 @@ "@opam/ocamlc-loc@opam:3.6.2@edc950a7", "@opam/fiber@opam:3.6.2@349136be", "@opam/dyn@opam:3.6.2@38120dfc", "@opam/dune-rpc@opam:3.6.2@d874b9d2", - "@opam/dune-build-info@opam:3.7.0@ce68449d", - "@opam/dune@opam:3.7.0@95218dc4", "@opam/csexp@opam:1.5.1@8a8fb3a7", - "@opam/chrome-trace@opam:3.7.0@6448e71e", + "@opam/dune-build-info@opam:3.7.1@adf0d411", + "@opam/dune@opam:3.7.1@40db2f22", "@opam/csexp@opam:1.5.1@8a8fb3a7", + "@opam/chrome-trace@opam:3.7.1@92d3c503", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/yojson@opam:2.0.2@eb65f292", - "@opam/xdg@opam:3.7.0@449d6490", "@opam/uutf@opam:1.0.3@47c95a18", + "@opam/xdg@opam:3.7.1@387cb889", "@opam/uutf@opam:1.0.3@47c95a18", "@opam/stdune@opam:3.6.2@47d75c4b", "@opam/spawn@opam:v0.15.1@85e9d6f1", "@opam/re@opam:1.10.4@c4910ba6", "@opam/ppx_yojson_conv_lib@opam:v0.15.0@773058a7", @@ -909,9 +992,34 @@ "@opam/ocamlc-loc@opam:3.6.2@edc950a7", "@opam/fiber@opam:3.6.2@349136be", "@opam/dyn@opam:3.6.2@38120dfc", "@opam/dune-rpc@opam:3.6.2@d874b9d2", - "@opam/dune-build-info@opam:3.7.0@ce68449d", - "@opam/dune@opam:3.7.0@95218dc4", "@opam/csexp@opam:1.5.1@8a8fb3a7", - "@opam/chrome-trace@opam:3.7.0@6448e71e" + "@opam/dune-build-info@opam:3.7.1@adf0d411", + "@opam/dune@opam:3.7.1@40db2f22", "@opam/csexp@opam:1.5.1@8a8fb3a7", + "@opam/chrome-trace@opam:3.7.1@92d3c503" + ] + }, + "@opam/ocaml-compiler-libs@opam:v0.12.4@41979882": { + "id": "@opam/ocaml-compiler-libs@opam:v0.12.4@41979882", + "name": "@opam/ocaml-compiler-libs", + "version": "opam:v0.12.4", + "source": { + "type": "install", + "source": [ + "archive:https://opam.ocaml.org/cache/sha256/4e/4ec9c9ec35cc45c18c7a143761154ef1d7663036a29297f80381f47981a07760#sha256:4ec9c9ec35cc45c18c7a143761154ef1d7663036a29297f80381f47981a07760", + "archive:https://github.com/janestreet/ocaml-compiler-libs/releases/download/v0.12.4/ocaml-compiler-libs-v0.12.4.tbz#sha256:4ec9c9ec35cc45c18c7a143761154ef1d7663036a29297f80381f47981a07760" + ], + "opam": { + "name": "ocaml-compiler-libs", + "version": "v0.12.4", + "path": "esy.lock/opam/ocaml-compiler-libs.v0.12.4" + } + }, + "overrides": [], + "dependencies": [ + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", + "@esy-ocaml/substs@0.0.1@d41d8cd9" + ], + "devDependencies": [ + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/mew_vi@opam:0.5.0@cf66c299": { @@ -933,12 +1041,12 @@ "overrides": [], "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/react@opam:1.2.2@e0f4480e", - "@opam/mew@opam:0.1.0@65011d4b", "@opam/dune@opam:3.7.0@95218dc4", + "@opam/mew@opam:0.1.0@65011d4b", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/react@opam:1.2.2@e0f4480e", - "@opam/mew@opam:0.1.0@65011d4b", "@opam/dune@opam:3.7.0@95218dc4" + "@opam/mew@opam:0.1.0@65011d4b", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/mew@opam:0.1.0@65011d4b": { @@ -960,12 +1068,12 @@ "overrides": [], "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/trie@opam:1.0.0@f4e510e2", - "@opam/result@opam:1.5@1c6a6533", "@opam/dune@opam:3.7.0@95218dc4", + "@opam/result@opam:1.5@1c6a6533", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/trie@opam:1.0.0@f4e510e2", - "@opam/result@opam:1.5@1c6a6533", "@opam/dune@opam:3.7.0@95218dc4" + "@opam/result@opam:1.5@1c6a6533", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/merlin-extend@opam:0.6.1@7d979feb": { @@ -986,89 +1094,89 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@opam/cppo@opam:1.6.9@db929a12", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, - "@opam/menhirSdk@opam:20220210@fe146ed3": { - "id": "@opam/menhirSdk@opam:20220210@fe146ed3", + "@opam/menhirSdk@opam:20230415@2aa219cc": { + "id": "@opam/menhirSdk@opam:20230415@2aa219cc", "name": "@opam/menhirSdk", - "version": "opam:20220210", + "version": "opam:20230415", "source": { "type": "install", "source": [ - "archive:https://opam.ocaml.org/cache/md5/e3/e3cef220f676c4b1c16cbccb174cefe3#md5:e3cef220f676c4b1c16cbccb174cefe3", - "archive:https://gitlab.inria.fr/fpottier/menhir/-/archive/20220210/archive.tar.gz#md5:e3cef220f676c4b1c16cbccb174cefe3" + "archive:https://opam.ocaml.org/cache/md5/7c/7c4b51e1b666711af04f7832ebc90618#md5:7c4b51e1b666711af04f7832ebc90618", + "archive:https://gitlab.inria.fr/fpottier/menhir/-/archive/20230415/archive.tar.gz#md5:7c4b51e1b666711af04f7832ebc90618" ], "opam": { "name": "menhirSdk", - "version": "20220210", - "path": "esy.lock/opam/menhirSdk.20220210" + "version": "20230415", + "path": "esy.lock/opam/menhirSdk.20230415" } }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, - "@opam/menhirLib@opam:20220210@9afeb270": { - "id": "@opam/menhirLib@opam:20220210@9afeb270", + "@opam/menhirLib@opam:20230415@78be630c": { + "id": "@opam/menhirLib@opam:20230415@78be630c", "name": "@opam/menhirLib", - "version": "opam:20220210", + "version": "opam:20230415", "source": { "type": "install", "source": [ - "archive:https://opam.ocaml.org/cache/md5/e3/e3cef220f676c4b1c16cbccb174cefe3#md5:e3cef220f676c4b1c16cbccb174cefe3", - "archive:https://gitlab.inria.fr/fpottier/menhir/-/archive/20220210/archive.tar.gz#md5:e3cef220f676c4b1c16cbccb174cefe3" + "archive:https://opam.ocaml.org/cache/md5/7c/7c4b51e1b666711af04f7832ebc90618#md5:7c4b51e1b666711af04f7832ebc90618", + "archive:https://gitlab.inria.fr/fpottier/menhir/-/archive/20230415/archive.tar.gz#md5:7c4b51e1b666711af04f7832ebc90618" ], "opam": { "name": "menhirLib", - "version": "20220210", - "path": "esy.lock/opam/menhirLib.20220210" + "version": "20230415", + "path": "esy.lock/opam/menhirLib.20230415" } }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, - "@opam/menhir@opam:20220210@ff5ea9a7": { - "id": "@opam/menhir@opam:20220210@ff5ea9a7", + "@opam/menhir@opam:20230415@ce1c9ac7": { + "id": "@opam/menhir@opam:20230415@ce1c9ac7", "name": "@opam/menhir", - "version": "opam:20220210", + "version": "opam:20230415", "source": { "type": "install", "source": [ - "archive:https://opam.ocaml.org/cache/md5/e3/e3cef220f676c4b1c16cbccb174cefe3#md5:e3cef220f676c4b1c16cbccb174cefe3", - "archive:https://gitlab.inria.fr/fpottier/menhir/-/archive/20220210/archive.tar.gz#md5:e3cef220f676c4b1c16cbccb174cefe3" + "archive:https://opam.ocaml.org/cache/md5/7c/7c4b51e1b666711af04f7832ebc90618#md5:7c4b51e1b666711af04f7832ebc90618", + "archive:https://gitlab.inria.fr/fpottier/menhir/-/archive/20230415/archive.tar.gz#md5:7c4b51e1b666711af04f7832ebc90618" ], "opam": { "name": "menhir", - "version": "20220210", - "path": "esy.lock/opam/menhir.20220210" + "version": "20230415", + "path": "esy.lock/opam/menhir.20230415" } }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/menhirSdk@opam:20220210@fe146ed3", - "@opam/menhirLib@opam:20220210@9afeb270", - "@opam/dune@opam:3.7.0@95218dc4", "@esy-ocaml/substs@0.0.1@d41d8cd9" + "ocaml@4.14.0@d41d8cd9", "@opam/menhirSdk@opam:20230415@2aa219cc", + "@opam/menhirLib@opam:20230415@78be630c", + "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/menhirSdk@opam:20220210@fe146ed3", - "@opam/menhirLib@opam:20220210@9afeb270", - "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/menhirSdk@opam:20230415@2aa219cc", + "@opam/menhirLib@opam:20230415@78be630c", + "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/lwt_react@opam:1.2.0@4253a145": { @@ -1090,12 +1198,12 @@ "overrides": [], "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/react@opam:1.2.2@e0f4480e", - "@opam/lwt@opam:5.6.1@2a9902ab", "@opam/dune@opam:3.7.0@95218dc4", + "@opam/lwt@opam:5.6.1@2a9902ab", "@opam/dune@opam:3.7.1@40db2f22", "@opam/cppo@opam:1.6.9@db929a12", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/react@opam:1.2.2@e0f4480e", - "@opam/lwt@opam:5.6.1@2a9902ab", "@opam/dune@opam:3.7.0@95218dc4" + "@opam/lwt@opam:5.6.1@2a9902ab", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/lwt@opam:5.6.1@2a9902ab": { @@ -1117,16 +1225,16 @@ "overrides": [], "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/ocplib-endian@opam:1.2@008dc942", - "@opam/dune-configurator@opam:3.7.0@4fa6f76e", - "@opam/dune@opam:3.7.0@95218dc4", "@opam/cppo@opam:1.6.9@db929a12", + "@opam/dune-configurator@opam:3.7.1@32ab7c21", + "@opam/dune@opam:3.7.1@40db2f22", "@opam/cppo@opam:1.6.9@db929a12", "@opam/base-unix@opam:base@87d0b2eb", "@opam/base-threads@opam:base@36803084", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/ocplib-endian@opam:1.2@008dc942", - "@opam/dune-configurator@opam:3.7.0@4fa6f76e", - "@opam/dune@opam:3.7.0@95218dc4" + "@opam/dune-configurator@opam:3.7.1@32ab7c21", + "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/logs@opam:0.7.0@46a3dffc": { @@ -1151,7 +1259,7 @@ "@opam/ocamlfind@opam:1.9.5@e83abf74", "@opam/ocamlbuild@opam:0.14.2@c6163b28", "@opam/lwt@opam:5.6.1@2a9902ab", "@opam/fmt@opam:0.9.0@87213963", - "@opam/cmdliner@opam:1.1.1@03763729", + "@opam/cmdliner@opam:1.2.0@b0c6143c", "@opam/base-threads@opam:base@36803084", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], @@ -1180,7 +1288,7 @@ "@opam/mew_vi@opam:0.5.0@cf66c299", "@opam/lwt_react@opam:1.2.0@4253a145", "@opam/lwt@opam:5.6.1@2a9902ab", "@opam/logs@opam:0.7.0@46a3dffc", - "@opam/dune@opam:3.7.0@95218dc4", "@esy-ocaml/substs@0.0.1@d41d8cd9" + "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/zed@opam:3.2.1@276736c0", @@ -1188,7 +1296,7 @@ "@opam/mew_vi@opam:0.5.0@cf66c299", "@opam/lwt_react@opam:1.2.0@4253a145", "@opam/lwt@opam:5.6.1@2a9902ab", "@opam/logs@opam:0.7.0@46a3dffc", - "@opam/dune@opam:3.7.0@95218dc4" + "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/fpath@opam:0.7.3@674d8125": { @@ -1240,7 +1348,7 @@ "ocaml@4.14.0@d41d8cd9", "@opam/topkg@opam:1.0.7@7ee47d76", "@opam/ocamlfind@opam:1.9.5@e83abf74", "@opam/ocamlbuild@opam:0.14.2@c6163b28", - "@opam/cmdliner@opam:1.1.1@03763729", + "@opam/cmdliner@opam:1.2.0@b0c6143c", "@opam/base-unix@opam:base@87d0b2eb", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], @@ -1264,11 +1372,11 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/fiber@opam:3.6.2@349136be": { @@ -1290,12 +1398,12 @@ "overrides": [], "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/stdune@opam:3.6.2@47d75c4b", - "@opam/dyn@opam:3.6.2@38120dfc", "@opam/dune@opam:3.7.0@95218dc4", + "@opam/dyn@opam:3.6.2@38120dfc", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/stdune@opam:3.6.2@47d75c4b", - "@opam/dyn@opam:3.6.2@38120dfc", "@opam/dune@opam:3.7.0@95218dc4" + "@opam/dyn@opam:3.6.2@38120dfc", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/dyn@opam:3.6.2@38120dfc": { @@ -1318,12 +1426,12 @@ "dependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/pp@opam:1.1.2@89ad03b5", "@opam/ordering@opam:3.6.2@37bc3093", - "@opam/dune@opam:3.7.0@95218dc4", "@esy-ocaml/substs@0.0.1@d41d8cd9" + "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9", "@opam/pp@opam:1.1.2@89ad03b5", "@opam/ordering@opam:3.6.2@37bc3093", - "@opam/dune@opam:3.7.0@95218dc4" + "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/dune-rpc@opam:3.6.2@d874b9d2": { @@ -1344,86 +1452,86 @@ }, "overrides": [], "dependencies": [ - "@opam/xdg@opam:3.7.0@449d6490", "@opam/stdune@opam:3.6.2@47d75c4b", + "@opam/xdg@opam:3.7.1@387cb889", "@opam/stdune@opam:3.6.2@47d75c4b", "@opam/pp@opam:1.1.2@89ad03b5", "@opam/ordering@opam:3.6.2@37bc3093", - "@opam/dyn@opam:3.6.2@38120dfc", "@opam/dune@opam:3.7.0@95218dc4", + "@opam/dyn@opam:3.6.2@38120dfc", "@opam/dune@opam:3.7.1@40db2f22", "@opam/csexp@opam:1.5.1@8a8fb3a7", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "@opam/xdg@opam:3.7.0@449d6490", "@opam/stdune@opam:3.6.2@47d75c4b", + "@opam/xdg@opam:3.7.1@387cb889", "@opam/stdune@opam:3.6.2@47d75c4b", "@opam/pp@opam:1.1.2@89ad03b5", "@opam/ordering@opam:3.6.2@37bc3093", - "@opam/dyn@opam:3.6.2@38120dfc", "@opam/dune@opam:3.7.0@95218dc4", + "@opam/dyn@opam:3.6.2@38120dfc", "@opam/dune@opam:3.7.1@40db2f22", "@opam/csexp@opam:1.5.1@8a8fb3a7" ] }, - "@opam/dune-configurator@opam:3.7.0@4fa6f76e": { - "id": "@opam/dune-configurator@opam:3.7.0@4fa6f76e", + "@opam/dune-configurator@opam:3.7.1@32ab7c21": { + "id": "@opam/dune-configurator@opam:3.7.1@32ab7c21", "name": "@opam/dune-configurator", - "version": "opam:3.7.0", + "version": "opam:3.7.1", "source": { "type": "install", "source": [ - "archive:https://opam.ocaml.org/cache/sha256/e2/e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8#sha256:e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8", - "archive:https://github.com/ocaml/dune/releases/download/3.7.0/dune-3.7.0.tbz#sha256:e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8" + "archive:https://opam.ocaml.org/cache/sha256/ad/adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3#sha256:adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3", + "archive:https://github.com/ocaml/dune/releases/download/3.7.1/dune-3.7.1.tbz#sha256:adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3" ], "opam": { "name": "dune-configurator", - "version": "3.7.0", - "path": "esy.lock/opam/dune-configurator.3.7.0" + "version": "3.7.1", + "path": "esy.lock/opam/dune-configurator.3.7.1" } }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@opam/csexp@opam:1.5.1@8a8fb3a7", "@opam/base-unix@opam:base@87d0b2eb", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@opam/csexp@opam:1.5.1@8a8fb3a7", "@opam/base-unix@opam:base@87d0b2eb" ] }, - "@opam/dune-build-info@opam:3.7.0@ce68449d": { - "id": "@opam/dune-build-info@opam:3.7.0@ce68449d", + "@opam/dune-build-info@opam:3.7.1@adf0d411": { + "id": "@opam/dune-build-info@opam:3.7.1@adf0d411", "name": "@opam/dune-build-info", - "version": "opam:3.7.0", + "version": "opam:3.7.1", "source": { "type": "install", "source": [ - "archive:https://opam.ocaml.org/cache/sha256/e2/e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8#sha256:e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8", - "archive:https://github.com/ocaml/dune/releases/download/3.7.0/dune-3.7.0.tbz#sha256:e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8" + "archive:https://opam.ocaml.org/cache/sha256/ad/adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3#sha256:adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3", + "archive:https://github.com/ocaml/dune/releases/download/3.7.1/dune-3.7.1.tbz#sha256:adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3" ], "opam": { "name": "dune-build-info", - "version": "3.7.0", - "path": "esy.lock/opam/dune-build-info.3.7.0" + "version": "3.7.1", + "path": "esy.lock/opam/dune-build-info.3.7.1" } }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, - "@opam/dune@opam:3.7.0@95218dc4": { - "id": "@opam/dune@opam:3.7.0@95218dc4", + "@opam/dune@opam:3.7.1@40db2f22": { + "id": "@opam/dune@opam:3.7.1@40db2f22", "name": "@opam/dune", - "version": "opam:3.7.0", + "version": "opam:3.7.1", "source": { "type": "install", "source": [ - "archive:https://opam.ocaml.org/cache/sha256/e2/e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8#sha256:e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8", - "archive:https://github.com/ocaml/dune/releases/download/3.7.0/dune-3.7.0.tbz#sha256:e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8" + "archive:https://opam.ocaml.org/cache/sha256/ad/adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3#sha256:adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3", + "archive:https://github.com/ocaml/dune/releases/download/3.7.1/dune-3.7.1.tbz#sha256:adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3" ], "opam": { "name": "dune", - "version": "3.7.0", - "path": "esy.lock/opam/dune.3.7.0" + "version": "3.7.1", + "path": "esy.lock/opam/dune.3.7.1" } }, "overrides": [], @@ -1455,11 +1563,11 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/cppo@opam:1.6.9@db929a12": { @@ -1480,29 +1588,29 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@opam/base-unix@opam:base@87d0b2eb", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@opam/base-unix@opam:base@87d0b2eb" ] }, - "@opam/cmdliner@opam:1.1.1@03763729": { - "id": "@opam/cmdliner@opam:1.1.1@03763729", + "@opam/cmdliner@opam:1.2.0@b0c6143c": { + "id": "@opam/cmdliner@opam:1.2.0@b0c6143c", "name": "@opam/cmdliner", - "version": "opam:1.1.1", + "version": "opam:1.2.0", "source": { "type": "install", "source": [ - "archive:https://opam.ocaml.org/cache/sha512/54/5478ad833da254b5587b3746e3a8493e66e867a081ac0f653a901cc8a7d944f66e4387592215ce25d939be76f281c4785702f54d4a74b1700bc8838a62255c9e#sha512:5478ad833da254b5587b3746e3a8493e66e867a081ac0f653a901cc8a7d944f66e4387592215ce25d939be76f281c4785702f54d4a74b1700bc8838a62255c9e", - "archive:https://erratique.ch/software/cmdliner/releases/cmdliner-1.1.1.tbz#sha512:5478ad833da254b5587b3746e3a8493e66e867a081ac0f653a901cc8a7d944f66e4387592215ce25d939be76f281c4785702f54d4a74b1700bc8838a62255c9e" + "archive:https://opam.ocaml.org/cache/sha512/6f/6fcd6a59a6fbc6986b1aecdc3e4ce7a0dc43c65a16b427d6caa5504b10b51384f6b0bc703af646b09f5f1caeb6827b37d4480ce350ca8006204c850785f2810b#sha512:6fcd6a59a6fbc6986b1aecdc3e4ce7a0dc43c65a16b427d6caa5504b10b51384f6b0bc703af646b09f5f1caeb6827b37d4480ce350ca8006204c850785f2810b", + "archive:https://erratique.ch/software/cmdliner/releases/cmdliner-1.2.0.tbz#sha512:6fcd6a59a6fbc6986b1aecdc3e4ce7a0dc43c65a16b427d6caa5504b10b51384f6b0bc703af646b09f5f1caeb6827b37d4480ce350ca8006204c850785f2810b" ], "opam": { "name": "cmdliner", - "version": "1.1.1", - "path": "esy.lock/opam/cmdliner.1.1.1" + "version": "1.2.0", + "path": "esy.lock/opam/cmdliner.1.2.0" } }, "overrides": [], @@ -1511,29 +1619,29 @@ ], "devDependencies": [ "ocaml@4.14.0@d41d8cd9" ] }, - "@opam/chrome-trace@opam:3.7.0@6448e71e": { - "id": "@opam/chrome-trace@opam:3.7.0@6448e71e", + "@opam/chrome-trace@opam:3.7.1@92d3c503": { + "id": "@opam/chrome-trace@opam:3.7.1@92d3c503", "name": "@opam/chrome-trace", - "version": "opam:3.7.0", + "version": "opam:3.7.1", "source": { "type": "install", "source": [ - "archive:https://opam.ocaml.org/cache/sha256/e2/e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8#sha256:e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8", - "archive:https://github.com/ocaml/dune/releases/download/3.7.0/dune-3.7.0.tbz#sha256:e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8" + "archive:https://opam.ocaml.org/cache/sha256/ad/adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3#sha256:adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3", + "archive:https://github.com/ocaml/dune/releases/download/3.7.1/dune-3.7.1.tbz#sha256:adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3" ], "opam": { "name": "chrome-trace", - "version": "3.7.0", - "path": "esy.lock/opam/chrome-trace.3.7.0" + "version": "3.7.1", + "path": "esy.lock/opam/chrome-trace.3.7.1" } }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/camlp-streams@opam:5.0.1@daaa0f94": { @@ -1554,11 +1662,11 @@ }, "overrides": [], "dependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4", + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22", "@esy-ocaml/substs@0.0.1@d41d8cd9" ], "devDependencies": [ - "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.0@95218dc4" + "ocaml@4.14.0@d41d8cd9", "@opam/dune@opam:3.7.1@40db2f22" ] }, "@opam/base-unix@opam:base@87d0b2eb": { diff --git a/esy.lock/opam/chrome-trace.3.7.0/opam b/esy.lock/opam/chrome-trace.3.7.1/opam similarity index 69% rename from esy.lock/opam/chrome-trace.3.7.0/opam rename to esy.lock/opam/chrome-trace.3.7.1/opam index 46cf1c78d..74649f970 100644 --- a/esy.lock/opam/chrome-trace.3.7.0/opam +++ b/esy.lock/opam/chrome-trace.3.7.1/opam @@ -30,10 +30,10 @@ build: [ ] ] url { - src: "https://github.com/ocaml/dune/releases/download/3.7.0/dune-3.7.0.tbz" + src: "https://github.com/ocaml/dune/releases/download/3.7.1/dune-3.7.1.tbz" checksum: [ - "sha256=e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8" - "sha512=586e47ee45cd53a8c13095bde0b47de99aad9462d0a52199362140b5b654ca862597fa9f27f729a8cc594684ac46858848f9fa76f8f06dc8dc8ab8b1186a3295" + "sha256=adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3" + "sha512=a74cd77ac7714f9434b5991c6dc02c6e6a2f46071d993a8985a9c9f0105182bb9e310ae2bcf7cf1d411c848d1a665e0fc0111b3597e5b1c6b634c1d398bea432" ] } -x-commit-hash: "d3d628f2eda2278bd2df6e37452d8693f367fcfd" +x-commit-hash: "e2b2d6aa984e3a5ddffa5ea00dd4f042dbf529a1" diff --git a/esy.lock/opam/cmdliner.1.1.1/opam b/esy.lock/opam/cmdliner.1.2.0/opam similarity index 90% rename from esy.lock/opam/cmdliner.1.1.1/opam rename to esy.lock/opam/cmdliner.1.2.0/opam index 702b586b3..b29bd296e 100644 --- a/esy.lock/opam/cmdliner.1.1.1/opam +++ b/esy.lock/opam/cmdliner.1.2.0/opam @@ -33,7 +33,7 @@ install: [ ] dev-repo: "git+https://erratique.ch/repos/cmdliner.git" url { - src: "https://erratique.ch/software/cmdliner/releases/cmdliner-1.1.1.tbz" + src: "https://erratique.ch/software/cmdliner/releases/cmdliner-1.2.0.tbz" checksum: - "sha512=5478ad833da254b5587b3746e3a8493e66e867a081ac0f653a901cc8a7d944f66e4387592215ce25d939be76f281c4785702f54d4a74b1700bc8838a62255c9e" + "sha512=6fcd6a59a6fbc6986b1aecdc3e4ce7a0dc43c65a16b427d6caa5504b10b51384f6b0bc703af646b09f5f1caeb6827b37d4480ce350ca8006204c850785f2810b" } \ No newline at end of file diff --git a/esy.lock/opam/dune-build-info.3.7.0/opam b/esy.lock/opam/dune-build-info.3.7.1/opam similarity index 75% rename from esy.lock/opam/dune-build-info.3.7.0/opam rename to esy.lock/opam/dune-build-info.3.7.1/opam index 059e6e18a..45de3528d 100644 --- a/esy.lock/opam/dune-build-info.3.7.0/opam +++ b/esy.lock/opam/dune-build-info.3.7.1/opam @@ -36,10 +36,10 @@ build: [ ] ] url { - src: "https://github.com/ocaml/dune/releases/download/3.7.0/dune-3.7.0.tbz" + src: "https://github.com/ocaml/dune/releases/download/3.7.1/dune-3.7.1.tbz" checksum: [ - "sha256=e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8" - "sha512=586e47ee45cd53a8c13095bde0b47de99aad9462d0a52199362140b5b654ca862597fa9f27f729a8cc594684ac46858848f9fa76f8f06dc8dc8ab8b1186a3295" + "sha256=adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3" + "sha512=a74cd77ac7714f9434b5991c6dc02c6e6a2f46071d993a8985a9c9f0105182bb9e310ae2bcf7cf1d411c848d1a665e0fc0111b3597e5b1c6b634c1d398bea432" ] } -x-commit-hash: "d3d628f2eda2278bd2df6e37452d8693f367fcfd" +x-commit-hash: "e2b2d6aa984e3a5ddffa5ea00dd4f042dbf529a1" diff --git a/esy.lock/opam/dune-configurator.3.7.0/opam b/esy.lock/opam/dune-configurator.3.7.1/opam similarity index 75% rename from esy.lock/opam/dune-configurator.3.7.0/opam rename to esy.lock/opam/dune-configurator.3.7.1/opam index c5555e817..be511dfee 100644 --- a/esy.lock/opam/dune-configurator.3.7.0/opam +++ b/esy.lock/opam/dune-configurator.3.7.1/opam @@ -40,10 +40,10 @@ build: [ ] ] url { - src: "https://github.com/ocaml/dune/releases/download/3.7.0/dune-3.7.0.tbz" + src: "https://github.com/ocaml/dune/releases/download/3.7.1/dune-3.7.1.tbz" checksum: [ - "sha256=e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8" - "sha512=586e47ee45cd53a8c13095bde0b47de99aad9462d0a52199362140b5b654ca862597fa9f27f729a8cc594684ac46858848f9fa76f8f06dc8dc8ab8b1186a3295" + "sha256=adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3" + "sha512=a74cd77ac7714f9434b5991c6dc02c6e6a2f46071d993a8985a9c9f0105182bb9e310ae2bcf7cf1d411c848d1a665e0fc0111b3597e5b1c6b634c1d398bea432" ] } -x-commit-hash: "d3d628f2eda2278bd2df6e37452d8693f367fcfd" +x-commit-hash: "e2b2d6aa984e3a5ddffa5ea00dd4f042dbf529a1" diff --git a/esy.lock/opam/dune.3.7.0/opam b/esy.lock/opam/dune.3.7.1/opam similarity index 79% rename from esy.lock/opam/dune.3.7.0/opam rename to esy.lock/opam/dune.3.7.1/opam index c9207f2cd..4a739625d 100644 --- a/esy.lock/opam/dune.3.7.0/opam +++ b/esy.lock/opam/dune.3.7.1/opam @@ -42,15 +42,15 @@ build: [ depends: [ # Please keep the lower bound in sync with .github/workflows/workflow.yml, # dune-project and min_ocaml_version in bootstrap.ml - ("ocaml" {>= "4.08"} | ("ocaml" {< "4.08~~"} & "ocamlfind-secondary")) + ("ocaml" {>= "4.08"} | ("ocaml" {>= "4.02" & < "4.08~~"} & "ocamlfind-secondary")) "base-unix" "base-threads" ] url { - src: "https://github.com/ocaml/dune/releases/download/3.7.0/dune-3.7.0.tbz" + src: "https://github.com/ocaml/dune/releases/download/3.7.1/dune-3.7.1.tbz" checksum: [ - "sha256=e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8" - "sha512=586e47ee45cd53a8c13095bde0b47de99aad9462d0a52199362140b5b654ca862597fa9f27f729a8cc594684ac46858848f9fa76f8f06dc8dc8ab8b1186a3295" + "sha256=adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3" + "sha512=a74cd77ac7714f9434b5991c6dc02c6e6a2f46071d993a8985a9c9f0105182bb9e310ae2bcf7cf1d411c848d1a665e0fc0111b3597e5b1c6b634c1d398bea432" ] } -x-commit-hash: "d3d628f2eda2278bd2df6e37452d8693f367fcfd" +x-commit-hash: "e2b2d6aa984e3a5ddffa5ea00dd4f042dbf529a1" diff --git a/esy.lock/opam/menhir.20220210/opam b/esy.lock/opam/menhir.20230415/opam similarity index 66% rename from esy.lock/opam/menhir.20220210/opam rename to esy.lock/opam/menhir.20230415/opam index 498658b42..d61711fc0 100644 --- a/esy.lock/opam/menhir.20220210/opam +++ b/esy.lock/opam/menhir.20230415/opam @@ -8,7 +8,7 @@ authors: [ homepage: "http://gitlab.inria.fr/fpottier/menhir" dev-repo: "git+https://gitlab.inria.fr/fpottier/menhir.git" bug-reports: "https://gitlab.inria.fr/fpottier/menhir/-/issues" -license: "LGPL-2.0-only WITH OCaml-LGPL-linking-exception" +license: "GPL-2.0-only" build: [ ["dune" "build" "-p" name "-j" jobs] ] @@ -21,9 +21,9 @@ depends: [ synopsis: "An LR(1) parser generator" url { src: - "https://gitlab.inria.fr/fpottier/menhir/-/archive/20220210/archive.tar.gz" + "https://gitlab.inria.fr/fpottier/menhir/-/archive/20230415/archive.tar.gz" checksum: [ - "md5=e3cef220f676c4b1c16cbccb174cefe3" - "sha512=3063fec1d8b9fe092c8461b0689d426c7fe381a2bf3fd258dc42ceecca1719d32efbb8a18d94ada5555c38175ea352da3adbb239fdbcbcf52c3a5c85a4d9586f" + "md5=7c4b51e1b666711af04f7832ebc90618" + "sha512=aa8a34c173d9a82d3503919de8377f1b8c9ff721882486f0b5ae2bdb9b22ee7f5ba8f6ef25e00fbb35704fac9fc3bda71908512ed4cbd345d9dc29d6ede149b2" ] } diff --git a/esy.lock/opam/menhirLib.20220210/opam b/esy.lock/opam/menhirLib.20230415/opam similarity index 67% rename from esy.lock/opam/menhirLib.20220210/opam rename to esy.lock/opam/menhirLib.20230415/opam index d2097ae4f..6673506d3 100644 --- a/esy.lock/opam/menhirLib.20220210/opam +++ b/esy.lock/opam/menhirLib.20230415/opam @@ -8,7 +8,7 @@ authors: [ homepage: "http://gitlab.inria.fr/fpottier/menhir" dev-repo: "git+https://gitlab.inria.fr/fpottier/menhir.git" bug-reports: "https://gitlab.inria.fr/fpottier/menhir/-/issues" -license: "LGPL-2.0-only WITH OCaml-LGPL-linking-exception" +license: "LGPL-2.0-only with OCaml-LGPL-linking-exception" build: [ ["dune" "build" "-p" name "-j" jobs] ] @@ -22,9 +22,9 @@ conflicts: [ synopsis: "Runtime support library for parsers generated by Menhir" url { src: - "https://gitlab.inria.fr/fpottier/menhir/-/archive/20220210/archive.tar.gz" + "https://gitlab.inria.fr/fpottier/menhir/-/archive/20230415/archive.tar.gz" checksum: [ - "md5=e3cef220f676c4b1c16cbccb174cefe3" - "sha512=3063fec1d8b9fe092c8461b0689d426c7fe381a2bf3fd258dc42ceecca1719d32efbb8a18d94ada5555c38175ea352da3adbb239fdbcbcf52c3a5c85a4d9586f" + "md5=7c4b51e1b666711af04f7832ebc90618" + "sha512=aa8a34c173d9a82d3503919de8377f1b8c9ff721882486f0b5ae2bdb9b22ee7f5ba8f6ef25e00fbb35704fac9fc3bda71908512ed4cbd345d9dc29d6ede149b2" ] } diff --git a/esy.lock/opam/menhirSdk.20220210/opam b/esy.lock/opam/menhirSdk.20230415/opam similarity index 67% rename from esy.lock/opam/menhirSdk.20220210/opam rename to esy.lock/opam/menhirSdk.20230415/opam index 585d2ca33..57f8ea866 100644 --- a/esy.lock/opam/menhirSdk.20220210/opam +++ b/esy.lock/opam/menhirSdk.20230415/opam @@ -8,7 +8,7 @@ authors: [ homepage: "http://gitlab.inria.fr/fpottier/menhir" dev-repo: "git+https://gitlab.inria.fr/fpottier/menhir.git" bug-reports: "https://gitlab.inria.fr/fpottier/menhir/-/issues" -license: "LGPL-2.0-only WITH OCaml-LGPL-linking-exception" +license: "LGPL-2.0-only with OCaml-LGPL-linking-exception" build: [ ["dune" "build" "-p" name "-j" jobs] ] @@ -22,9 +22,9 @@ conflicts: [ synopsis: "Compile-time library for auxiliary tools related to Menhir" url { src: - "https://gitlab.inria.fr/fpottier/menhir/-/archive/20220210/archive.tar.gz" + "https://gitlab.inria.fr/fpottier/menhir/-/archive/20230415/archive.tar.gz" checksum: [ - "md5=e3cef220f676c4b1c16cbccb174cefe3" - "sha512=3063fec1d8b9fe092c8461b0689d426c7fe381a2bf3fd258dc42ceecca1719d32efbb8a18d94ada5555c38175ea352da3adbb239fdbcbcf52c3a5c85a4d9586f" + "md5=7c4b51e1b666711af04f7832ebc90618" + "sha512=aa8a34c173d9a82d3503919de8377f1b8c9ff721882486f0b5ae2bdb9b22ee7f5ba8f6ef25e00fbb35704fac9fc3bda71908512ed4cbd345d9dc29d6ede149b2" ] } diff --git a/esy.lock/opam/ocaml-compiler-libs.v0.12.4/opam b/esy.lock/opam/ocaml-compiler-libs.v0.12.4/opam new file mode 100644 index 000000000..14c9f7537 --- /dev/null +++ b/esy.lock/opam/ocaml-compiler-libs.v0.12.4/opam @@ -0,0 +1,39 @@ +opam-version: "2.0" +synopsis: "OCaml compiler libraries repackaged" +description: """ +This packages exposes the OCaml compiler libraries repackages under +the toplevel names Ocaml_common, Ocaml_bytecomp, Ocaml_optcomp, ...""" +maintainer: ["Jane Street developers"] +authors: ["Jane Street Group, LLC"] +license: "MIT" +homepage: "https://github.com/janestreet/ocaml-compiler-libs" +bug-reports: "https://github.com/janestreet/ocaml-compiler-libs/issues" +depends: [ + "dune" {>= "2.8"} + "ocaml" {>= "4.04.1"} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/janestreet/ocaml-compiler-libs.git" +url { + src: + "https://github.com/janestreet/ocaml-compiler-libs/releases/download/v0.12.4/ocaml-compiler-libs-v0.12.4.tbz" + checksum: [ + "sha256=4ec9c9ec35cc45c18c7a143761154ef1d7663036a29297f80381f47981a07760" + "sha512=978dba8dfa61f98fa24fda7a9c26c2e837081f37d1685fe636dc19cfc3278a940cf01a10293504b185c406706bc1008bc54313d50f023bcdea6d5ac6c0788b35" + ] +} +x-commit-hash: "8cd12f18bb7171c2b67d661868c4271fae528d93" diff --git a/esy.lock/opam/ppxlib.0.29.1/opam b/esy.lock/opam/ppxlib.0.29.1/opam new file mode 100644 index 000000000..4170d25c1 --- /dev/null +++ b/esy.lock/opam/ppxlib.0.29.1/opam @@ -0,0 +1,63 @@ +opam-version: "2.0" +synopsis: "Standard library for ppx rewriters" +description: """ +Ppxlib is the standard library for ppx rewriters and other programs +that manipulate the in-memory representation of OCaml programs, a.k.a +the "Parsetree". + +It also comes bundled with two ppx rewriters that are commonly used to +write tools that manipulate and/or generate Parsetree values; +`ppxlib.metaquot` which allows to construct Parsetree values using the +OCaml syntax directly and `ppxlib.traverse` which provides various +ways of automatically traversing values of a given type, in particular +allowing to inject a complex structured value into generated code. +""" +maintainer: ["opensource@janestreet.com"] +authors: ["Jane Street Group, LLC "] +license: "MIT" +homepage: "https://github.com/ocaml-ppx/ppxlib" +doc: "https://ocaml-ppx.github.io/ppxlib/" +bug-reports: "https://github.com/ocaml-ppx/ppxlib/issues" +depends: [ + "dune" {>= "2.7"} + "ocaml" {>= "4.04.1" & < "5.1.0"} + "ocaml-compiler-libs" {>= "v0.11.0"} + "ppx_derivers" {>= "1.0"} + "sexplib0" {>= "v0.12"} + "sexplib0" {with-test & >= "v0.15"} + "stdlib-shims" + "ocamlfind" {with-test} + "re" {with-test & >= "1.9.0"} + "cinaps" {with-test & >= "v0.12.1"} + "base" {with-test} + "stdio" {with-test} + "odoc" {with-doc} +] +conflicts: [ + "ocaml-migrate-parsetree" {< "2.0.0"} + "base-effects" +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/ocaml-ppx/ppxlib.git" +url { + src: + "https://github.com/ocaml-ppx/ppxlib/releases/download/0.29.1/ppxlib-0.29.1.tbz" + checksum: [ + "sha256=c8ea8c8770414fdba6612e7f2d814b21a493daa974ea862a90c8e6c766e5dd79" + "sha512=edc468e9111cc26e31825e475fd72f55123a22fe86548e07e7d111796fecb8d60359b1b53c7eac383e5e2114cbae74dfd9c166f330e84cbeab4ddfd5797e322f" + ] +} +x-commit-hash: "36fcba0408b78963a730e0be92abdbab00b0ea26" diff --git a/esy.lock/opam/sexplib0.v0.15.1/opam b/esy.lock/opam/sexplib0.v0.15.1/opam new file mode 100644 index 000000000..123ccd03c --- /dev/null +++ b/esy.lock/opam/sexplib0.v0.15.1/opam @@ -0,0 +1,26 @@ +opam-version: "2.0" +maintainer: "Jane Street developers" +authors: ["Jane Street Group, LLC"] +homepage: "https://github.com/janestreet/sexplib0" +bug-reports: "https://github.com/janestreet/sexplib0/issues" +dev-repo: "git+https://github.com/janestreet/sexplib0.git" +doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/sexplib0/index.html" +license: "MIT" +build: [ + ["dune" "build" "-p" name "-j" jobs] +] +depends: [ + "ocaml" {>= "4.08"} + "dune" {>= "2.0.0"} +] +synopsis: "Library containing the definition of S-expressions and some base converters" +description: " +Part of Jane Street's Core library +The Core suite of libraries is an industrial strength alternative to +OCaml's standard library that was developed by Jane Street, the +largest industrial user of OCaml. +" +url { +src: "https://github.com/janestreet/sexplib0/archive/refs/tags/v0.15.1.tar.gz" +checksum: "md5=ab8fd6273f35a792cad48cbb3024a7f9" +} diff --git a/esy.lock/opam/stdlib-shims.0.3.0/opam b/esy.lock/opam/stdlib-shims.0.3.0/opam new file mode 100644 index 000000000..8c9695710 --- /dev/null +++ b/esy.lock/opam/stdlib-shims.0.3.0/opam @@ -0,0 +1,31 @@ +opam-version: "2.0" +maintainer: "The stdlib-shims programmers" +authors: "The stdlib-shims programmers" +homepage: "https://github.com/ocaml/stdlib-shims" +doc: "https://ocaml.github.io/stdlib-shims/" +dev-repo: "git+https://github.com/ocaml/stdlib-shims.git" +bug-reports: "https://github.com/ocaml/stdlib-shims/issues" +tags: ["stdlib" "compatibility" "org:ocaml"] +license: ["LGPL-2.1-only WITH OCaml-LGPL-linking-exception"] +depends: [ + "dune" + "ocaml" {>= "4.02.3"} +] +build: [ "dune" "build" "-p" name "-j" jobs ] +synopsis: "Backport some of the new stdlib features to older compiler" +description: """ +Backport some of the new stdlib features to older compiler, +such as the Stdlib module. + +This allows projects that require compatibility with older compiler to +use these new features in their code. +""" +x-commit-hash: "fb6815e5d745f07fd567c11671149de6ef2e74c8" +url { + src: + "https://github.com/ocaml/stdlib-shims/releases/download/0.3.0/stdlib-shims-0.3.0.tbz" + checksum: [ + "sha256=babf72d3917b86f707885f0c5528e36c63fccb698f4b46cf2bab5c7ccdd6d84a" + "sha512=1151d7edc8923516e9a36995a3f8938d323aaade759ad349ed15d6d8501db61ffbe63277e97c4d86149cf371306ac23df0f581ec7e02611f58335126e1870980" + ] +} diff --git a/esy.lock/opam/utop.2.11.0/opam b/esy.lock/opam/utop.2.12.0/opam similarity index 79% rename from esy.lock/opam/utop.2.11.0/opam rename to esy.lock/opam/utop.2.12.0/opam index d9f71c3cd..fde17cc37 100644 --- a/esy.lock/opam/utop.2.11.0/opam +++ b/esy.lock/opam/utop.2.12.0/opam @@ -34,10 +34,10 @@ and more. It integrates with the Tuareg mode in Emacs. """ url { src: - "https://github.com/ocaml-community/utop/releases/download/2.11.0/utop-2.11.0.tbz" + "https://github.com/ocaml-community/utop/releases/download/2.12.0/utop-2.12.0.tbz" checksum: [ - "sha256=6937c6c672913ac3b875341ac4a205c7561d01cd8ac8f47cfb35d3bc0e762170" - "sha512=ab8b96eaa7f24654a371245f14819b74de0907ed8f3b2bbd9196808dc10e536458cf95418eeacf6dfc4b7f64a8dd088ee31e2eaae3d9ebc7de7cebcada52fb84" + "sha256=ad19c859a783bec573cd91e810c54d0e6b70f339d0a4fed55ec672ae408aa1ea" + "sha512=cd55cfb49178bec60b39df5b15df9090d9a316b81ddd5e564daaaa04c3c896c2e1ccf24a15ebce5b41ad3e22db56cfc95cc3f1a6808ee8e09f1c685284cdfb71" ] } -x-commit-hash: "595002e6f07e6a3c6abc6e94a1b2448006115f1b" +x-commit-hash: "c50173caf9b147eae637cb44e302e2077778afb4" diff --git a/esy.lock/opam/xdg.3.7.0/opam b/esy.lock/opam/xdg.3.7.1/opam similarity index 68% rename from esy.lock/opam/xdg.3.7.0/opam rename to esy.lock/opam/xdg.3.7.1/opam index fe21970ac..18778392f 100644 --- a/esy.lock/opam/xdg.3.7.0/opam +++ b/esy.lock/opam/xdg.3.7.1/opam @@ -30,10 +30,10 @@ build: [ ] ] url { - src: "https://github.com/ocaml/dune/releases/download/3.7.0/dune-3.7.0.tbz" + src: "https://github.com/ocaml/dune/releases/download/3.7.1/dune-3.7.1.tbz" checksum: [ - "sha256=e2d637c9d080318fedf5e71d2a29fb367624f82ac4a26e83df2b3a03550528b8" - "sha512=586e47ee45cd53a8c13095bde0b47de99aad9462d0a52199362140b5b654ca862597fa9f27f729a8cc594684ac46858848f9fa76f8f06dc8dc8ab8b1186a3295" + "sha256=adfc38f14c0188a2ad80d61451d011d27ab8839b717492d7ad42f7cb911c54c3" + "sha512=a74cd77ac7714f9434b5991c6dc02c6e6a2f46071d993a8985a9c9f0105182bb9e310ae2bcf7cf1d411c848d1a665e0fc0111b3597e5b1c6b634c1d398bea432" ] } -x-commit-hash: "d3d628f2eda2278bd2df6e37452d8693f367fcfd" +x-commit-hash: "e2b2d6aa984e3a5ddffa5ea00dd4f042dbf529a1" diff --git a/flake.lock b/flake.lock index 80d7f1920..5b53b8411 100644 --- a/flake.lock +++ b/flake.lock @@ -1,12 +1,15 @@ { "nodes": { "flake-utils": { + "inputs": { + "systems": "systems" + }, "locked": { - "lastModified": 1678901627, - "narHash": "sha256-U02riOqrKKzwjsxc/400XnElV+UtPUQWpANPlyazjH0=", + "lastModified": 1681202837, + "narHash": "sha256-H+Rh19JDwRtpVPAWp64F+rlEtxUWBAQW28eAi3SRSzg=", "owner": "numtide", "repo": "flake-utils", - "rev": "93a2b84fc4b70d9e089d029deacc3583435c2ed6", + "rev": "cfacdce06f30d2b68473a46042957675eebb3401", "type": "github" }, "original": { @@ -17,11 +20,11 @@ }, "nix-filter": { "locked": { - "lastModified": 1678109515, - "narHash": "sha256-C2X+qC80K2C1TOYZT8nabgo05Dw2HST/pSn6s+n6BO8=", + "lastModified": 1681154353, + "narHash": "sha256-MCJ5FHOlbfQRFwN0brqPbCunLEVw05D/3sRVoNVt2tI=", "owner": "numtide", "repo": "nix-filter", - "rev": "aa9ff6ce4a7f19af6415fb3721eaa513ea6c763c", + "rev": "f529f42792ade8e32c4be274af6b6d60857fbee7", "type": "github" }, "original": { @@ -38,11 +41,11 @@ "nixpkgs": "nixpkgs_2" }, "locked": { - "lastModified": 1679617087, - "narHash": "sha256-rDcPKOEAsj9o8UeT5UMMKOURhJcM7eGC3Buzd+T69mw=", + "lastModified": 1681761444, + "narHash": "sha256-FM2yAWrPnAITvMgRlgqNSpCh1ieKvLmd+pG144bp8Ks=", "owner": "nix-ocaml", "repo": "nix-overlays", - "rev": "2b78ff251eec962ba83b0af72c7b9e02f6627717", + "rev": "9859e425c67c121709f323a54fda2e4e456a3196", "type": "github" }, "original": { @@ -53,17 +56,17 @@ }, "nixpkgs_2": { "locked": { - "lastModified": 1679542234, - "narHash": "sha256-NrUIxT2MtOcRDLq+bAFqAUno4w9Ds7UDaKQj+3yJPQk=", + "lastModified": 1681713375, + "narHash": "sha256-UPDEwrzOQLTNzNDMkcf3J7+7vV3zlQCCrO33kwlFsdY=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "99265ac4a8c83e4109f9cfc7c911707b86437b67", + "rev": "9a60b3eef1a0ccb4e3459eba1814bae91d07134e", "type": "github" }, "original": { "owner": "NixOS", "repo": "nixpkgs", - "rev": "99265ac4a8c83e4109f9cfc7c911707b86437b67", + "rev": "9a60b3eef1a0ccb4e3459eba1814bae91d07134e", "type": "github" } }, @@ -73,6 +76,21 @@ "nix-filter": "nix-filter", "nixpkgs": "nixpkgs" } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } } }, "root": "root", diff --git a/nix/default.nix b/nix/default.nix index 1f57f67ed..bb502f9dd 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -24,6 +24,8 @@ ocamlPackages.buildDunePackage { cppo fix ppx_derivers + ppxlib + dune-build-info ]; } diff --git a/reason.json b/reason.json index 3e027f07f..021476468 100644 --- a/reason.json +++ b/reason.json @@ -14,6 +14,7 @@ "@opam/menhir": " >= 20180523.0.0", "@opam/merlin-extend": " >= 0.6", "@opam/ppx_derivers": "< 2.0.0", + "@opam/ppxlib": "> 0.28.x", "@opam/dune": ">= 2.9.3", "@opam/dune-build-info": ">= 2.9.3" }, diff --git a/reason.opam b/reason.opam index 51eb29b52..4eaf5db39 100644 --- a/reason.opam +++ b/reason.opam @@ -23,6 +23,7 @@ depends: [ "merlin-extend" {>= "0.6"} "fix" "ppx_derivers" + "ppxlib" {>= "0.28.0"} "odoc" {with-doc} ] build: [ diff --git a/src/ppx/dune b/src/ppx/dune deleted file mode 100644 index fa41af888..000000000 --- a/src/ppx/dune +++ /dev/null @@ -1,6 +0,0 @@ -(executable - (name reactjs_jsx_ppx_v2) - (public_name reactjs_jsx_ppx_v2) - (package reason) - (flags (:standard -w -9)) - (libraries reason reason.ocaml-migrate-parsetree)) diff --git a/src/ppx/reactjs_jsx_ppx_v2.ml b/src/ppx/reactjs_jsx_ppx_v2.ml deleted file mode 100644 index 6d25a71d2..000000000 --- a/src/ppx/reactjs_jsx_ppx_v2.ml +++ /dev/null @@ -1,411 +0,0 @@ -(* - This is the file that handles turning Reason JSX' agnostic function call into - a ReasonReact-specific function call. Aka, this is a macro, using OCaml's ppx - facilities; https://whitequark.org/blog/2014/04/16/a-guide-to-extension- - points-in-ocaml/ - - You wouldn't use this file directly; it's used by BuckleScript's - bsconfig.json. Specifically, there's a field called `react-jsx` inside the - field `reason`, which enables this ppx through some internal call in bsb -*) - -(* - The actual transform: - - transform `[@JSX] div(~props1=a, ~props2=b, ~children=[foo, bar], ())` into - `ReactDOMRe.createElement("div", ~props={"props1": 1, "props2": b}, [|foo, - bar|])`. - - transform `[@JSX] div(~props1=a, ~props2=b, ~children=foo, ())` into - `ReactDOMRe.createElementVariadic("div", ~props={"props1": 1, "props2": b}, foo)`. - - transform the upper-cased case - `[@JSX] Foo.createElement(~key=a, ~ref=b, ~foo=bar, ~children=[], ())` into - `ReasonReact.element(~key=a, ~ref=b, Foo.make(~foo=bar, [||]))` - - transform `[@JSX] [foo]` into - `ReactDOMRe.createElement(ReasonReact.fragment, [|foo|])` -*) - -(* - This file's shared between the Reason repo and the BuckleScript repo. In - Reason, it's in src. In BuckleScript, it's in jscomp/bin. We periodically - copy this file from Reason (the source of truth) to BuckleScript, then - uncomment the #if #else #end cppo macros you see in the file. That's because - BuckleScript's on OCaml 4.02 while Reason's on 4.04; so the #if macros - surround the pieces of code that are different between the two compilers. - - When you modify this file, please make sure you're not dragging in too many - things. You don't necessarily have to test the file on both Reason and - BuckleScript; ping @chenglou and a few others and we'll keep them synced up by - patching the right parts, through the power of types(tm) -*) - -(* #if defined BS_NO_COMPILER_PATCH then *) -open Reason_omp -open Ast_411 -module To_current = Convert(OCaml_411)(OCaml_current) - -let nolabel = Ast_411.Asttypes.Nolabel -let labelled str = Ast_411.Asttypes.Labelled str -let argIsKeyRef = function - | (Asttypes.Labelled ("key" | "ref"), _) | (Asttypes.Optional ("key" | "ref"), _) -> true - | _ -> false -let constantString ~loc str = - Ast_helper.Exp.constant ~loc (Parsetree.Pconst_string (str, loc, None)) - -(* #else -let nolabel = "" -let labelled str = str -let argIsKeyRef = function - | (("key" | "ref"), _) | (("?key" | "?ref"), _) -> true - | _ -> false -let constantString ~loc str = Ast_helper.Exp.constant ~loc (Asttypes.Const_string (str, None)) -#end *) - -open Ast_helper -open Ast_mapper -open Asttypes -open Parsetree -open Longident - -(* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) -let transformChildrenIfList ~loc ~mapper theList = - let rec transformChildren_ theList accum = - (* not in the sense of converting a list to an array; convert the AST - reprensentation of a list to the AST reprensentation of an array *) - match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> - List.rev accum |> Exp.array ~loc - | {pexp_desc = Pexp_construct ( - {txt = Lident "::"}, - Some {pexp_desc = Pexp_tuple (v::acc::[])} - )} -> - transformChildren_ acc ((mapper.expr mapper v)::accum) - | notAList -> mapper.expr mapper notAList - in - transformChildren_ theList [] - -let extractChildren ?(removeLastPositionUnit=false) ~loc propsAndChildren = - let rec allButLast_ lst acc = match lst with - | [] -> [] -(* #if defined BS_NO_COMPILER_PATCH then *) - | (Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})::[] -> acc - | (Nolabel, _)::_ -> raise (Invalid_argument "JSX: found non-labelled argument before the last position") -(* #else - | ("", {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})::[] -> acc - | ("", _)::rest -> raise (Invalid_argument "JSX: found non-labelled argument before the last position") -#end *) - | arg::rest -> allButLast_ rest (arg::acc) - in - let allButLast lst = allButLast_ lst [] |> List.rev in - match (List.partition (fun (label, _) -> label = labelled "children") propsAndChildren) with - | ([], props) -> - (* no children provided? Place a placeholder list *) - (Exp.construct ~loc {loc; txt = Lident "[]"} None, if removeLastPositionUnit then allButLast props else props) - | ([(_, childrenExpr)], props) -> - (childrenExpr, if removeLastPositionUnit then allButLast props else props) - | _ -> raise (Invalid_argument "JSX: somehow there's more than one `children` label") - -(* TODO: some line number might still be wrong *) -let jsxMapper () = - - let jsxVersion = ref None in - - let transformUppercaseCall modulePath mapper loc attrs _ callArguments = - let (children, argsWithLabels) = extractChildren ~loc ~removeLastPositionUnit:true callArguments in - let (argsKeyRef, argsForMake) = List.partition argIsKeyRef argsWithLabels in - let childrenExpr = transformChildrenIfList ~loc ~mapper children in - let recursivelyTransformedArgsForMake = argsForMake |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) in - let args = recursivelyTransformedArgsForMake @ [ (nolabel, childrenExpr) ] in - let wrapWithReasonReactElement e = (* ReasonReact.element(~key, ~ref, ...) *) - Exp.apply - ~loc - (Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "element")}) - (argsKeyRef @ [(nolabel, e)]) in - Exp.apply - ~loc - ~attrs - (* Foo.make *) - (Exp.ident ~loc {loc; txt = Ldot (modulePath, "make")}) - args - |> wrapWithReasonReactElement in - - let transformLowercaseCall mapper loc attrs callArguments id = - let (children, nonChildrenProps) = extractChildren ~loc callArguments in - let componentNameExpr = constantString ~loc id in - let childrenExpr = transformChildrenIfList ~loc ~mapper children in - let createElementCall = match children with - (* [@JSX] div(~children=[a]), coming from
a
*) - | { - pexp_desc = - Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _ }) - | Pexp_construct ({txt = Lident "[]"}, None) - } -> "createElement" - (* [@JSX] div(~children=[|a|]), coming from
...[|a|]
*) - | { pexp_desc = (Pexp_array _) } -> - raise (Invalid_argument "A spread + an array literal as a DOM element's \ - children would cancel each other out, and thus don't make sense written \ - together. You can simply remove the spread and the array literal.") - (* [@JSX] div(~children=
), coming from
...
*) - | { - pexp_attributes - } when pexp_attributes |> List.exists (fun { attr_name = { txt }; _} -> txt = "JSX") -> - raise (Invalid_argument "A spread + a JSX literal as a DOM element's \ - children don't make sense written together. You can simply remove the spread.") - | _ -> "createElementVariadic" - in - let args = match nonChildrenProps with - | [_justTheUnitArgumentAtEnd] -> - [ - (* "div" *) - (nolabel, componentNameExpr); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr) - ] - | nonEmptyProps -> - let propsCall = - Exp.apply - ~loc - (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "props")}) - (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression))) - in - [ - (* "div" *) - (nolabel, componentNameExpr); - (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) - (labelled "props", propsCall); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr) - ] in - Exp.apply - ~loc - (* throw away the [@JSX] attribute and keep the others, if any *) - ~attrs - (* ReactDOMRe.createElement *) - (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) - args - in - - let transformJsxCall mapper callExpression callArguments attrs = - (match callExpression.pexp_desc with - | Pexp_ident caller -> - (match caller with - | {txt = Lident "createElement"} -> - raise (Invalid_argument "JSX: `createElement` should be preceeded by a module name.") - - (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) - | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> - (match !jsxVersion with - | None - | Some 2 -> transformUppercaseCall modulePath mapper loc attrs callExpression callArguments - | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 2")) - - (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) - (* turn that into - ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) - | {loc; txt = Lident id} -> - transformLowercaseCall mapper loc attrs callArguments id - - | {txt = Ldot (_, anythingNotCreateElementOrMake)} -> - raise ( - Invalid_argument - ("JSX: the JSX attribute should be attached to a `YourModuleName.createElement` or `YourModuleName.make` call. We saw `" - ^ anythingNotCreateElementOrMake - ^ "` instead" - ) - ) - - | {txt = Lapply _} -> - (* don't think there's ever a case where this is reached *) - raise ( - Invalid_argument "JSX: encountered a weird case while processing the code. Please report this!" - ) - ) - | _ -> - raise ( - Invalid_argument "JSX: `createElement` should be preceeded by a simple, direct module name." - ) - ) in - - let structure = - (fun mapper structure -> match structure with - (* - match against [@bs.config {foo, jsx: ...}] at the file-level. This - indicates which version of JSX we're using. This code stays here because - we used to have 2 versions of JSX PPX (and likely will again in the - future when JSX PPX changes). So the architecture for switching between - JSX behavior stayed here. To create a new JSX ppx, copy paste this - entire file and change the relevant parts. - - Description of architecture: in bucklescript's bsconfig.json, you can - specify a project-wide JSX version. You can also specify a file-level - JSX version. This degree of freedom allows a person to convert a project - one file at time onto the new JSX, when it was released. It also enabled - a project to depend on a third-party which is still using an old version - of JSX - *) - | { - pstr_loc; - pstr_desc = Pstr_attribute { - attr_name = ({txt = "bs.config"} as bsConfigLabel); - attr_payload = PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (recordFields, b)} as innerConfigRecord, a)} as configRecord] - }; _ - }::restOfStructure -> begin - let (jsxField, recordFieldsWithoutJsx) = recordFields |> List.partition (fun ({txt}, _) -> txt = Lident "jsx") in - match (jsxField, recordFieldsWithoutJsx) with - (* no file-level jsx config found *) - | ([], _) -> default_mapper.structure mapper structure - (* {jsx: 2} *) -(* #if defined BS_NO_COMPILER_PATCH then *) - | ((_, {pexp_desc = Pexp_constant (Pconst_integer (version, _))})::_, recordFieldsWithoutJsx) -> begin - (match version with - | "2" -> jsxVersion := Some 2 - | _ -> raise (Invalid_argument "JSX: the file-level bs.config's jsx version must be 2")); -(* #else - | ((_, {pexp_desc = Pexp_constant (Const_int version)})::rest, recordFieldsWithoutJsx) -> begin - (match version with - | 2 -> jsxVersion := Some 2 - | _ -> raise (Invalid_argument "JSX: the file-level bs.config's jsx version must be 2")); -#end *) - match recordFieldsWithoutJsx with - (* record empty now, remove the whole bs.config attribute *) - | [] -> default_mapper.structure mapper restOfStructure - | fields -> default_mapper.structure mapper ({ - pstr_loc; - pstr_desc = Pstr_attribute ( - { attr_name = bsConfigLabel; - attr_payload = PStr [{configRecord with pstr_desc = Pstr_eval ({innerConfigRecord with pexp_desc = Pexp_record (fields, b)}, a)}]; - attr_loc = bsConfigLabel.loc - }) - }::restOfStructure) - end - | _ -> raise (Invalid_argument "JSX: the file-level bs.config's {jsx: ...} config accepts only a version number") - end - | _ -> default_mapper.structure mapper structure - ) in - - let expr = - (fun mapper expression -> match expression with - (* Does the function application have the @JSX attribute? *) - | { - pexp_desc = Pexp_apply (callExpression, callArguments); - pexp_attributes - } -> - let (jsxAttribute, nonJSXAttributes) = List.partition (fun { attr_name = {txt}; _} -> txt = "JSX") pexp_attributes in - (match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | ([], _) -> default_mapper.expr mapper expression - | (_, nonJSXAttributes) -> transformJsxCall mapper callExpression callArguments nonJSXAttributes) - - (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) - | { - pexp_desc = - Pexp_construct ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"; loc}, None); - pexp_attributes - } as listItems -> - let (jsxAttribute, nonJSXAttributes) = List.partition (fun {attr_name = {txt}} -> txt = "JSX") pexp_attributes in - (match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | ([], _) -> default_mapper.expr mapper expression - | (_, nonJSXAttributes) -> - let fragment = Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "fragment")} in - let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in - let args = [ - (* "div" *) - (nolabel, fragment); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr) - ] in - Exp.apply - ~loc - (* throw away the [@JSX] attribute and keep the others, if any *) - ~attrs:nonJSXAttributes - (* ReactDOMRe.createElement *) - (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "createElement")}) - args - ) - (* Delegate to the default mapper, a deep identity traversal *) - | e -> default_mapper.expr mapper e) in - -(* #if defined BS_NO_COMPILER_PATCH then *) - To_current.copy_mapper { default_mapper with structure; expr } -(* #else - { default_mapper with structure; expr } -#end *) - -(* #if BS_COMPILER_IN_BROWSER then - -module Js = struct - module Unsafe = struct - type any - external inject : 'a -> any = "%identity" - external get : 'a -> 'b -> 'c = "caml_js_get" - external set : 'a -> 'b -> 'c -> unit = "caml_js_set" - external pure_js_expr : string -> 'a = "caml_pure_js_expr" - let global = pure_js_expr "joo_global_object" - external obj : (string * any) array -> 'a = "caml_js_object" - end - type (-'a, +'b) meth_callback - type 'a callback = (unit, 'a) meth_callback - external wrap_meth_callback : ('a -> 'b) -> ('a, 'b) meth_callback = "caml_js_wrap_meth_callback" - type + 'a t - type js_string - external string : string -> js_string t = "caml_js_from_string" - external to_string : js_string t -> string = "caml_js_to_string" -end - -(* keep in sync with jscomp/core/jsoo_main.ml `let implementation` *) -let rewrite code = - let mapper = jsxMapper () in - Location.input_name := "//toplevel//"; - try - let lexer = Lexing.from_string code in - let pstr = Parse.implementation lexer in - let pstr = mapper.structure mapper pstr in - let buffer = Buffer.create 1000 in - Pprintast.structure Format.str_formatter pstr; - let ocaml_code = Format.flush_str_formatter () in - Js.Unsafe.(obj [| "ocaml_code", inject @@ Js.string ocaml_code |]) - with e -> - match Location.error_of_exn e with - | Some error -> - Location.report_error Format.err_formatter error; - let (file, line, startchar) = Location.get_pos_info error.loc.loc_start in - let (file, endline, endchar) = Location.get_pos_info error.loc.loc_end in - Js.Unsafe.(obj - [| - "ppx_error_msg", inject @@ Js.string (Printf.sprintf "Line %d, %d: %s" line startchar error.msg); - "row", inject (line - 1); - "column", inject startchar; - "endRow", inject (endline - 1); - "endColumn", inject endchar; - "text", inject @@ Js.string error.msg; - "type", inject @@ Js.string "error"; - |] - ) - | None -> - Js.Unsafe.(obj [| - "js_error_msg" , inject @@ Js.string (Printexc.to_string e) - |]) - -let export (field : string) v = - Js.Unsafe.set (Js.Unsafe.global) field v - -let make_ppx name = - export name - (Js.Unsafe.(obj - [|"rewrite", - inject @@ - Js.wrap_meth_callback - (fun _ code -> rewrite (Js.to_string code)); - |])) - -let () = make_ppx "jsxv2" *) - -(* #elif defined BS_NO_COMPILER_PATCH then *) -let () = Compiler_libs.Ast_mapper.register "JSX" (fun _argv -> jsxMapper ()) -(* #else -let () = Ast_mapper.register "JSX" (fun _argv -> jsxMapper ()) -#end *) diff --git a/src/ppx/reactjs_jsx_ppx_v2.mli b/src/ppx/reactjs_jsx_ppx_v2.mli deleted file mode 100644 index 4900fe06f..000000000 --- a/src/ppx/reactjs_jsx_ppx_v2.mli +++ /dev/null @@ -1,11 +0,0 @@ -(* - This file's shared between the Reason repo and the BuckleScript repo. In - Reason, it's in src. In BuckleScript, it's in vendor/reason We periodically - copy this file from Reason (the source of truth) to BuckleScript, then - uncomment the #if #else #end cppo macros you see in the file. That's because - BuckleScript's on OCaml 4.02 while Reason's on 4.04; so the #if macros - surround the pieces of code that are different between the two compilers. - *) -(* #if undefined BS_NO_COMPILER_PATCH then *) -(* val ast_mapper : Ast_mapper.mapper *) -(* #end *) diff --git a/src/reason-merlin/ocamlmerlin_reason.cppo.ml b/src/reason-merlin/ocamlmerlin_reason.cppo.ml index 89415e289..352b9b979 100644 --- a/src/reason-merlin/ocamlmerlin_reason.cppo.ml +++ b/src/reason-merlin/ocamlmerlin_reason.cppo.ml @@ -10,13 +10,17 @@ module Reason_reader = struct let structure str = let str = - Reason_syntax_util.(apply_mapper_to_structure str (backport_letopt_mapper remove_stylistic_attrs_mapper)) + str + |> Reason_syntax_util.(apply_mapper_to_structure remove_stylistic_attrs_mapper) + |> Reason_syntax_util.(apply_mapper_to_structure backport_letopt_mapper) in Structure (Reason_toolchain.To_current.copy_structure str) let signature sg = let sg = - Reason_syntax_util.(apply_mapper_to_signature sg (backport_letopt_mapper remove_stylistic_attrs_mapper)) + sg + |> Reason_syntax_util.(apply_mapper_to_signature remove_stylistic_attrs_mapper) + |> Reason_syntax_util.(apply_mapper_to_signature backport_letopt_mapper) in Signature (Reason_toolchain.To_current.copy_signature sg) diff --git a/src/reason-parser-tests/testOprint.cppo.ml b/src/reason-parser-tests/testOprint.cppo.ml index 00cc7ade4..233c2deb4 100644 --- a/src/reason-parser-tests/testOprint.cppo.ml +++ b/src/reason-parser-tests/testOprint.cppo.ml @@ -20,9 +20,9 @@ *) open Reason_omp +module Ast = Ast_414 -module Convert = Reason_omp.Convert (Reason_omp.OCaml_411) (Reason_omp.OCaml_current) -module ConvertBack = Reason_omp.Convert (Reason_omp.OCaml_current) (Reason_omp.OCaml_411) +module ConvertBack = Reason_omp.Convert (Reason_omp.OCaml_current) (Reason_omp.OCaml_414) let main () = let filename = "./TestTest.ml" in @@ -39,7 +39,7 @@ let main () = Env.set_unit_name modulename; let ast = impl lexbuf in - let ast = Convert.copy_structure ast in + let ast = Reason_toolchain.To_current.copy_structure ast in let env = Compmisc.initial_env() in #if OCAML_VERSION >= (4,13,0) let { Typedtree.structure = typedtree; _ } = @@ -48,7 +48,7 @@ let main () = #endif Typemod.type_implementation modulename modulename modulename env ast in let tree = Printtyp.tree_of_signature typedtree.Typedtree.str_type in - let phrase = (Ast_411.Outcometree.Ophr_signature + let phrase = (Ast.Outcometree.Ophr_signature (List.map (fun item -> (ConvertBack.copy_out_sig_item item, None)) tree) ) in let fmt = Format.str_formatter in diff --git a/src/reason-parser/dune b/src/reason-parser/dune index 580775f1d..2bb29de80 100644 --- a/src/reason-parser/dune +++ b/src/reason-parser/dune @@ -121,4 +121,8 @@ reason_parser_explain_raw reason_parser_explain reason_parser_recover) - (libraries reason.ocaml-migrate-parsetree menhirLib reason.easy_format)) + (libraries + reason.ocaml-migrate-parsetree + menhirLib + reason.easy_format + ppxlib)) diff --git a/src/reason-parser/reason_attributes.ml b/src/reason-parser/reason_attributes.ml index c412496d9..a272ebdfa 100644 --- a/src/reason-parser/reason_attributes.ml +++ b/src/reason-parser/reason_attributes.ml @@ -1,5 +1,4 @@ -open Reason_omp -open Ast_411 +open Ppxlib open Location open Parsetree diff --git a/src/reason-parser/reason_errors.ml b/src/reason-parser/reason_errors.ml index c7dc30487..e5ea39342 100644 --- a/src/reason-parser/reason_errors.ml +++ b/src/reason-parser/reason_errors.ml @@ -10,6 +10,7 @@ A fourth case is when unknown / unexpected error occurs. *) +open Ppxlib open Format type lexing_error = @@ -127,8 +128,6 @@ let () = | _ -> None ) -open Reason_omp.Ast_411 - let str_eval_message text = { Parsetree. pstr_loc = Location.none; diff --git a/src/reason-parser/reason_errors.mli b/src/reason-parser/reason_errors.mli index 05e547d61..b9f7b8489 100644 --- a/src/reason-parser/reason_errors.mli +++ b/src/reason-parser/reason_errors.mli @@ -8,7 +8,7 @@ was too fine to be captured by the grammar rules *) -open Reason_omp.Ast_411 +open Ppxlib type lexing_error = | Illegal_character of char diff --git a/src/reason-parser/reason_heuristics.ml b/src/reason-parser/reason_heuristics.ml index 360e1e7f5..405186684 100644 --- a/src/reason-parser/reason_heuristics.ml +++ b/src/reason-parser/reason_heuristics.ml @@ -1,7 +1,7 @@ -open Reason_omp +open Ppxlib let is_punned_labelled_expression e lbl = - let open Ast_411.Parsetree in + let open Parsetree in match e.pexp_desc with | Pexp_ident { txt } | Pexp_constraint ({pexp_desc = Pexp_ident { txt }}, _) @@ -17,11 +17,11 @@ let is_punned_labelled_expression e lbl = * where the sum of the string contents and identifier names are less than the print width *) let funAppCallbackExceedsWidth ~printWidth ~args ~funExpr () = - let open Ast_411.Parsetree in - let open Ast_411.Asttypes in + let open Parsetree in + let open Asttypes in let funLen = begin match funExpr.pexp_desc with | Pexp_ident ident -> - let identList = Longident.flatten ident.txt in + let identList = Longident.flatten_exn ident.txt in let lengthOfDots = List.length identList - 1 in let len = List.fold_left (fun acc curr -> acc + (String.length curr)) lengthOfDots identList in @@ -39,7 +39,7 @@ let funAppCallbackExceedsWidth ~printWidth ~args ~funExpr () = | (label, ({ pexp_desc = Pexp_ident ident } as e)) -> let identLen = List.fold_left (fun acc curr -> acc + (String.length curr) - ) len (Longident.flatten ident.txt) in + ) len (Longident.flatten_exn ident.txt) in begin match label with | Nolabel -> aux (len - identLen) args | Labelled s when is_punned_labelled_expression e s -> @@ -88,17 +88,17 @@ let singleTokenPatternOmmitTrail txt = String.length txt < 4 * -> setTimeout((.) => Js.log("hola"), 1000); *) let bsExprCanBeUncurried expr = - match Ast_411.Parsetree.(expr.pexp_desc) with + match Parsetree.(expr.pexp_desc) with | Pexp_fun _ | Pexp_apply _ -> true | _ -> false let isUnderscoreIdent expr = - match Ast_411.Parsetree.(expr.pexp_desc) with + match Parsetree.(expr.pexp_desc) with | Pexp_ident ({txt = Lident "_"}) -> true | _ -> false -let isPipeFirst e = match Ast_411.Parsetree.(e.pexp_desc) with +let isPipeFirst e = match Parsetree.(e.pexp_desc) with | Pexp_ident({txt = Longident.Lident("|.")}) -> true | Pexp_apply( {pexp_desc = Pexp_ident({txt = Longident.Lident("|.")})}, @@ -107,7 +107,7 @@ let isPipeFirst e = match Ast_411.Parsetree.(e.pexp_desc) with | _ -> false let isUnderscoreApplication expr = - let open Ast_411.Parsetree in + let open Parsetree in match expr with | {pexp_attributes = []; pexp_desc = Pexp_fun( Nolabel, @@ -125,7 +125,7 @@ let isUnderscoreApplication expr = * An application with pipe first inside jsx children requires special treatment. * Jsx children don't allow expression application, hence we need the braces * preserved in this case. *) -let isPipeFirstWithNonSimpleJSXChild e = match Ast_411.Parsetree.(e.pexp_desc) with +let isPipeFirstWithNonSimpleJSXChild e = match Parsetree.(e.pexp_desc) with | Pexp_apply( {pexp_desc = Pexp_ident({txt = Longident.Lident("|.")})}, [Nolabel, {pexp_desc = Pexp_apply(_)}; _] diff --git a/src/reason-parser/reason_oprint.ml b/src/reason-parser/reason_oprint.ml index 21cb27180..0951e83b2 100644 --- a/src/reason-parser/reason_oprint.ml +++ b/src/reason-parser/reason_oprint.ml @@ -84,10 +84,8 @@ patching the right parts, through the power of types(tm) *) -open Reason_omp -open Ast_411 - open Format +module Outcometree = Reason_omp.Ast_414.Outcometree open Outcometree exception Ellipsis @@ -451,15 +449,15 @@ and print_simple_out_type ppf = fprintf ppf "@[<1>%a@]" print_out_type ty; | Otyp_abstract | Otyp_open | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> () - | Otyp_module (p, n, tyl) -> + + | Otyp_module (p, ntyls) -> fprintf ppf "@[<1>(module %a" print_ident p; let first = ref true in - List.iter2 - (fun s t -> + List.iter + (fun (s, t) -> let sep = if !first then (first := false; "with") else "and" in - fprintf ppf " %s type %s = %a" sep s print_out_type t - ) - n tyl; + fprintf ppf " %s type %s = %a" sep s print_out_type t) + ntyls; fprintf ppf ")@]" | Otyp_attribute (t, attr) -> fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name @@ -520,15 +518,12 @@ and print_typargs ppf = let out_type = ref print_out_type -(* Class types *) let variance = function - (* co, contra *) - | false, false -> "" - | true, true -> "" - | true, false -> "+" - | false, true -> "-" + | Reason_omp.Ast_414.Asttypes.NoVariance -> "" + | Covariant -> "+" + | Contravariant -> "-" -let type_parameter ppf (ty, var) = +let type_parameter ppf (ty, (var, _)) = fprintf ppf "%s%s" (variance var) (if ty = "_" then ty else "'"^ty) @@ -636,13 +631,19 @@ and print_out_signature ppf = match items with Osig_typext(ext, Oext_next) :: items -> gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) + ( { ocstr_name = ext.oext_name; + ocstr_args = ext.oext_args; + ocstr_return_type = ext.oext_ret_type; + } :: acc) items | _ -> (List.rev acc, items) in let exts, items = gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] + [ { ocstr_name = ext.oext_name + ; ocstr_args = ext.oext_args + ; ocstr_return_type = ext.oext_ret_type + } ] items in let te = @@ -670,7 +671,11 @@ and print_out_sig_item ppf = print_out_class_type clt | Osig_typext (ext, Oext_exception) -> fprintf ppf "@[<2>exception %a@]" - print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type) + print_out_constr + { ocstr_name = ext.oext_name + ; ocstr_args = ext.oext_args + ; ocstr_return_type = ext.oext_ret_type + } | Osig_typext (ext, _) -> print_out_extension_constructor ppf ext | Osig_modtype (name, Omty_abstract) -> @@ -754,8 +759,8 @@ and print_out_type_decl kwd ppf td = | _ -> td.otype_type in let print_private ppf = function - Asttypes.Private -> fprintf ppf " pri" - | Asttypes.Public -> () + Reason_omp.Ast_414.Asttypes.Private -> fprintf ppf " pri" + | Public -> () in let print_out_tkind ppf = function | Otyp_abstract -> () @@ -779,7 +784,7 @@ and print_out_type_decl kwd ppf td = print_out_tkind ty print_constraints -and print_out_constr ppf (name, tyl,ret_type_opt) = +and print_out_constr ppf {ocstr_name =name; ocstr_args = tyl; ocstr_return_type = ret_type_opt} = match ret_type_opt with | None -> begin match tyl with @@ -832,8 +837,12 @@ and print_out_extension_constructor ppf ext = in fprintf ppf "@[type %t +=%s@;<1 2>%a@]" print_extended_type - (if ext.oext_private = Asttypes.Private then " pri" else "") - print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type) + (if ext.oext_private = Reason_omp.Ast_414.Asttypes.Private then " pri" else "") + print_out_constr + { ocstr_name = ext.oext_name + ; ocstr_args = ext.oext_args + ; ocstr_return_type = ext.oext_ret_type + } and print_out_type_extension ppf te = let print_extended_type ppf = @@ -855,7 +864,7 @@ and print_out_type_extension ppf te = in fprintf ppf "@[type %t +=%s@;<1 2>%a@]" print_extended_type - (if te.otyext_private = Asttypes.Private then " pri" else "") + (if te.otyext_private = Reason_omp.Ast_414.Asttypes.Private then " pri" else "") (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) te.otyext_constructors @@ -878,13 +887,13 @@ let rec print_items ppf = match items with (Osig_typext(ext, Oext_next), None) :: items -> gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) + ({ocstr_name = ext.oext_name; ocstr_args = ext.oext_args; ocstr_return_type = ext.oext_ret_type} :: acc) items | _ -> (List.rev acc, items) in let exts, items = gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] + [{ ocstr_name = ext.oext_name; ocstr_args = ext.oext_args; ocstr_return_type = ext.oext_ret_type}] items in let te = diff --git a/src/reason-parser/reason_parser.mly b/src/reason-parser/reason_parser.mly index aa98fd8d1..719ffdefd 100644 --- a/src/reason-parser/reason_parser.mly +++ b/src/reason-parser/reason_parser.mly @@ -48,18 +48,24 @@ (* The parser definition *) %{ -open Reason_omp -open OCaml_411.Ast +open Ppxlib open Reason_syntax_util open Location open Asttypes open Longident open Parsetree open Ast_helper -open Ast_mapper open Reason_parser_def open Reason_errors +(* Menhir generates `Warnings.loc` *) +module Warnings = struct + type loc = Location.t +end + +let mkloc txt loc = {txt;loc} +let mknoloc txt = mkloc txt none + let raise_error error loc = raise_error (Ast_error error) loc @@ -357,10 +363,10 @@ let ghexp_cons args loc = mkexp ~ghost:true ~loc (Pexp_construct(mkloc (Lident "::") loc, Some args)) let mkpat_cons args loc = - mkpat ~loc (Ppat_construct(mkloc (Lident "::") loc, Some args)) + mkpat ~loc (Ppat_construct(mkloc (Lident "::") loc, Some ([], args))) let ghpat_cons args loc = - mkpat ~ghost:true ~loc (Ppat_construct(mkloc (Lident "::") loc, Some args)) + mkpat ~ghost:true ~loc (Ppat_construct(mkloc (Lident "::") loc, Some ([], args))) let mkpat_constructor_unit consloc loc = mkpat ~loc (Ppat_construct(mkloc (Lident "()") consloc, None)) @@ -688,10 +694,10 @@ let bigarray_set ?(loc=dummy_loc()) arr arg newval = Nolabel, newval])) let exp_of_label label = - mkexp ~loc:label.loc (Pexp_ident {label with txt=Lident(Longident.last label.txt)}) + mkexp ~loc:label.loc (Pexp_ident {label with txt=Lident(Longident.last_exn label.txt)}) let pat_of_label label = - mkpat ~loc:label.loc (Ppat_var {label with txt=(Longident.last label.txt)}) + mkpat ~loc:label.loc (Ppat_var {label with txt=(Longident.last_exn label.txt)}) let check_variable vl loc v = if List.mem v vl then @@ -844,9 +850,11 @@ let class_of_let_bindings lbs body = * unwrap the tuple to expose the inner tuple directly. * *) -let arity_conflict_resolving_mapper super = -{ super with - expr = begin fun mapper expr -> +let reason_to_ml_swap_operator_mapper = new reason_to_ml_swap_operator_mapper +let reason_mapper = object + inherit Ppxlib.Ast_traverse.map as super + + method! expression expr = match expr with | {pexp_desc=Pexp_construct(lid, args); pexp_loc; @@ -855,37 +863,34 @@ let arity_conflict_resolving_mapper super = match args with | Some {pexp_desc = Pexp_tuple [sp]} -> Some sp | _ -> args in - super.expr mapper + super#expression { pexp_desc=Pexp_construct(lid, new_args); pexp_loc; pexp_attributes = normalized_attributes "explicit_arity" pexp_attributes; pexp_loc_stack = [] } - | x -> super.expr mapper x - end; - pat = begin fun mapper pattern -> + | x -> super#expression x + method! pattern pattern = match pattern with | {ppat_desc=Ppat_construct(lid, args); ppat_loc; ppat_attributes} when attributes_conflicted "implicit_arity" "explicit_arity" ppat_attributes -> let new_args = match args with - | Some {ppat_desc = Ppat_tuple [sp]} -> Some sp - | _ -> args in - super.pat mapper + | Some (x, {ppat_desc = Ppat_tuple [sp]}) -> Some (x, sp) + | _ -> args + in + super#pattern { ppat_desc=Ppat_construct(lid, new_args); ppat_loc; ppat_attributes = normalized_attributes "explicit_arity" ppat_attributes; ppat_loc_stack = []; } - | x -> super.pat mapper x - end; -} + | x -> super#pattern x +end -let reason_mapper = - default_mapper - |> reason_to_ml_swap_operator_mapper - |> arity_conflict_resolving_mapper +let reason_mapper f a = + a |> f reason_to_ml_swap_operator_mapper |> f reason_mapper let rewriteFunctorApp module_name elt loc = let rec applies = function @@ -1050,7 +1055,7 @@ let package_type_of_module_type pmty = let add_brace_attr expr = let attr = { - attr_name = Location.mknoloc "reason.preserve_braces"; + attr_name = mknoloc "reason.preserve_braces"; attr_payload = PStr []; attr_loc = Location.none } @@ -1061,14 +1066,14 @@ let add_brace_attr expr = %[@recover.prelude - open Reason_omp.OCaml_411.Ast + open Ppxlib open Parsetree open Ast_helper let default_loc = ref Location.none let default_expr () = - let id = Location.mkloc "merlin.hole" !default_loc in + let id = Location.{txt = "merlin.hole"; loc = !default_loc} in Exp.mk ~loc:!default_loc (Pexp_extension (id, PStr [])) let default_pattern () = Pat.any ~loc:!default_loc () @@ -1358,19 +1363,19 @@ conflicts. (* Entry points *) %start implementation (* for implementation files *) -%type implementation +%type implementation %start interface (* for interface files *) -%type interface +%type interface %start toplevel_phrase (* for interactive use *) -%type toplevel_phrase +%type toplevel_phrase %start use_file (* for the #use directive *) -%type use_file +%type use_file %start parse_core_type -%type parse_core_type +%type parse_core_type %start parse_expression -%type parse_expression +%type parse_expression %start parse_pattern -%type parse_pattern +%type parse_pattern (* Instead of reporting an error directly, productions specified * below will be reduced first and popped up in the stack to a higher @@ -1403,19 +1408,19 @@ conflicts. implementation: structure EOF - { apply_mapper_to_structure $1 reason_mapper } + { reason_mapper apply_mapper_to_structure $1 } ; interface: signature EOF - { apply_mapper_to_signature $1 reason_mapper } + { reason_mapper apply_mapper_to_signature $1 } ; toplevel_phrase: embedded ( EOF { raise End_of_file } | structure_item SEMI { Ptop_def $1 } | toplevel_directive SEMI { $1 } - ) { apply_mapper_to_toplevel_phrase $1 reason_mapper } + ) { reason_mapper apply_mapper_to_toplevel_phrase $1 } ; use_file_no_mapper: embedded @@ -1428,22 +1433,22 @@ use_file_no_mapper: embedded ; use_file: - use_file_no_mapper { apply_mapper_to_use_file $1 reason_mapper } + use_file_no_mapper { reason_mapper apply_mapper_to_use_file $1 } ; parse_core_type: core_type EOF - { apply_mapper_to_type $1 reason_mapper } + { reason_mapper apply_mapper_to_type $1 } ; parse_expression: expr EOF - { apply_mapper_to_expr $1 reason_mapper } + { reason_mapper apply_mapper_to_expr $1 } ; parse_pattern: pattern EOF - { apply_mapper_to_pattern $1 reason_mapper } + { reason_mapper apply_mapper_to_pattern $1 } ; (* Module expressions *) @@ -2645,7 +2650,7 @@ es6_parameters: | as_loc(UNDERSCORE) { ([{$1 with txt = Term (Nolabel, None, mkpat ~loc:$1.loc Ppat_any)}], false) } | simple_pattern_ident - { ([Location.mkloc (Term (Nolabel, None, $1)) $1.ppat_loc], false) } + { ([mkloc (Term (Nolabel, None, $1)) $1.ppat_loc], false) } ; (* TODO: properly fix JSX labelled/optional stuff *) @@ -3260,12 +3265,12 @@ labeled_expr: | Some typ -> ghexp_constraint $2.loc exp typ in - (Labelled (Longident.last lident_loc.txt), labeled_exp) + (Labelled (Longident.last_exn lident_loc.txt), labeled_exp) } | TILDE as_loc(val_longident) QUESTION { (* foo(~a?) -> parses ~a? *) let exp = mkexp (Pexp_ident $2) ~loc:$2.loc in - (Optional (Longident.last $2.txt), exp) + (Optional (Longident.last_exn $2.txt), exp) } | TILDE as_loc(LIDENT) EQUAL optional labeled_expr_constraint { (* foo(~bar=?Some(1)) or add(~x=1, ~y=2) -> parses ~bar=?Some(1) & ~x=1 & ~y=1 *) @@ -3678,11 +3683,11 @@ mark_position_pat *) { match is_pattern_list_single_any $2 with | Some singleAnyPat -> - mkpat (Ppat_construct($1, Some singleAnyPat)) + mkpat (Ppat_construct($1, Some ([], singleAnyPat))) | None -> let loc = mklocation $symbolstartpos $endpos in let argPattern = simple_pattern_list_to_tuple ~loc $2 in - mkExplicitArityTuplePat (Ppat_construct($1, Some argPattern)) + mkExplicitArityTuplePat (Ppat_construct($1, Some ([], argPattern))) } | name_tag simple_pattern { mkpat (Ppat_variant($1, Some $2)) } @@ -4027,12 +4032,12 @@ type_variables_with_variance: type_variable_with_variance: embedded - ( QUOTE ident { (mktyp (Ptyp_var $2) , Invariant ) } - | UNDERSCORE { (mktyp (Ptyp_any) , Invariant ) } - | PLUS QUOTE ident { (mktyp (Ptyp_var $3) , Covariant ) } - | PLUS UNDERSCORE { (mktyp (Ptyp_any) , Covariant ) } - | MINUS QUOTE ident { (mktyp (Ptyp_var $3) , Contravariant) } - | MINUS UNDERSCORE { (mktyp Ptyp_any , Contravariant) } + ( QUOTE ident { (mktyp (Ptyp_var $2) , (NoVariance, NoInjectivity) ) } + | UNDERSCORE { (mktyp (Ptyp_any) , (NoVariance, NoInjectivity) ) } + | PLUS QUOTE ident { (mktyp (Ptyp_var $3) , (Covariant, NoInjectivity) ) } + | PLUS UNDERSCORE { (mktyp (Ptyp_any) , (Covariant, NoInjectivity) ) } + | MINUS QUOTE ident { (mktyp (Ptyp_var $3) , (Contravariant, NoInjectivity)) } + | MINUS UNDERSCORE { (mktyp Ptyp_any , (Contravariant, NoInjectivity)) } ) { let first, second = $1 in let ptyp_loc = @@ -4042,10 +4047,10 @@ type_variable_with_variance: } ; -type_parameter: type_variance type_variable { ($2, $1) }; +type_parameter: type_variance type_variable { ($2, ($1, NoInjectivity)) }; type_variance: - | (* empty *) { Invariant } + | (* empty *) { NoVariance } | PLUS { Covariant } | MINUS { Contravariant } ; @@ -4222,7 +4227,7 @@ with_constraint: | TYPE as_loc(label_longident) type_variables_with_variance EQUAL embedded(private_flag) core_type constraints { let loc = mklocation $symbolstartpos $endpos in - let typ = Type.mk {$2 with txt=Longident.last $2.txt} + let typ = Type.mk {$2 with txt=Longident.last_exn $2.txt} ~params:$3 ~cstrs:$7 ~manifest:$6 ~priv:$5 ~loc in Pwith_type ($2, typ) } @@ -4642,7 +4647,7 @@ constant: | None -> [] | Some raw -> let constant = Exp.constant (Pconst_string (raw, loc, None)) in - [ { attr_name = Location.mkloc "reason.raw_literal" loc; + [ { attr_name = mkloc "reason.raw_literal" loc; attr_payload = PStr [mkstrexp constant []]; attr_loc = Location.none } ] diff --git a/src/reason-parser/reason_parser_def.ml b/src/reason-parser/reason_parser_def.ml index 0521994c1..17df73b02 100644 --- a/src/reason-parser/reason_parser_def.ml +++ b/src/reason-parser/reason_parser_def.ml @@ -1,4 +1,4 @@ -open Reason_omp.OCaml_411.Ast +open Ppxlib type labelled_parameter = | Term of Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern diff --git a/src/reason-parser/reason_pprint_ast.ml b/src/reason-parser/reason_pprint_ast.ml index 5d7d005ef..668540a30 100644 --- a/src/reason-parser/reason_pprint_ast.ml +++ b/src/reason-parser/reason_pprint_ast.ml @@ -48,8 +48,7 @@ module Easy_format = Vendored_easy_format -open Reason_omp -open Ast_411 +open Ppxlib open Asttypes open Location open Longident @@ -178,7 +177,7 @@ let add_extension_sugar keyword = function let string_equal : string -> string -> bool = (=) -let string_loc_equal: string Ast_411.Asttypes.loc -> string Ast_411.Asttypes.loc -> bool = +let string_loc_equal: string Asttypes.loc -> string Asttypes.loc -> bool = fun l1 l2 -> l1.txt = l2.txt let longident_same l1 l2 = @@ -301,7 +300,7 @@ let expandLocation pos ~expand:(startPos, endPos) = * 2| let f = ... by the attr on line 1, not the lnum of the `let` *) let rec firstAttrLoc loc = function - | ({ attr_name = attrLoc; _} : Ast_411.Parsetree.attribute) ::attrs -> + | ({ attr_name = attrLoc; _} : Parsetree.attribute) ::attrs -> if attrLoc.loc.loc_start.pos_lnum < loc.loc_start.pos_lnum && not attrLoc.loc.loc_ghost then @@ -729,7 +728,7 @@ let override = function (* variance encoding: need to sync up with the [parser.mly] *) let type_variance = function - | Invariant -> "" + | NoVariance -> "" | Covariant -> "+" | Contravariant -> "-" @@ -2052,13 +2051,13 @@ let recordRowIsPunned pld = ptyp_attributes = []; _} when - (Longident.last txt = name + (Longident.last_exn txt = name (* Don't pun types from other modules, e.g. type bar = {foo: Baz.foo}; *) && isLongIdentWithDot txt == false) -> true | _ -> false) let isPunnedJsxArg lbl ident = - not (isLongIdentWithDot ident.txt) && (Longident.last ident.txt) = lbl + not (isLongIdentWithDot ident.txt) && (Longident.last_exn ident.txt) = lbl let is_unit_pattern x = match x.ppat_desc with | Ppat_construct ( {txt= Lident"()"}, None) -> true @@ -2514,7 +2513,7 @@ let printer = object(self:'self) makeList ~postSpace:true [atom "."; t] else t - method type_param (ct, a) = + method type_param (ct, (a, _)) = makeList [atom (type_variance a); self#core_type ct] (* According to the parse rule [type_declaration], the "type declaration"'s @@ -2626,7 +2625,7 @@ let printer = object(self:'self) in let sourceMappedName = atom ~loc:pext_name.loc pext_name.txt in let resolved = match pext_kind with - | Pext_decl (ctor_args, gadt) -> + | Pext_decl (_, ctor_args, gadt) -> let formattedArgs = match ctor_args with | Pcstr_tuple [] -> [] | Pcstr_tuple args -> [makeTup (List.map self#non_arrowed_non_simple_core_type args)] @@ -3101,7 +3100,7 @@ let printer = object(self:'self) self#type_variant_leaf ~opt_ampersand ~polymorphic:true - {pcd_name = label; pcd_args; pcd_res; pcd_loc = label.loc; pcd_attributes = all_attrs} + {pcd_name = label; pcd_args; pcd_res; pcd_loc = label.loc; pcd_attributes = all_attrs; pcd_vars = []} | Rinherit ct -> (* '| type' is required if the Rinherit is not the first row_field in the list @@ -3147,7 +3146,7 @@ let printer = object(self:'self) | { ppat_desc = Ppat_construct ( { txt = Lident("::")}, - Some {ppat_desc = Ppat_tuple ([pat1; pat2])} + Some ([], {ppat_desc = Ppat_tuple ([pat1; pat2])}) ) } -> self#pattern_list_split_cons (pat1::acc) pat2 | p -> (List.rev acc), p @@ -3255,7 +3254,7 @@ let printer = object(self:'self) (* ppat_attributes=[{txt="explicit_arity"; loc}] *) (* }) -> *) (* label ~space:true (self#longident_loc li) (makeSpacedBreakableInlineList (List.map self#simple_pattern l)) *) - | Some pattern -> + | Some (_, pattern) -> let arityIsClear = isArityClear arityAttrs in self#constructor_pattern ~arityIsClear (self#longident_loc li) pattern | None -> @@ -3507,10 +3506,10 @@ let printer = object(self:'self) match loc.txt with | Ldot (moduleLid, "createElement") -> Some (self#formatJSXComponent - (String.concat "." (Longident.flatten moduleLid)) l) + (String.concat "." (Longident.flatten_exn moduleLid)) l) | lid -> Some (self#formatJSXComponent - (String.concat "." (Longident.flatten lid)) l) + (String.concat "." (Longident.flatten_exn lid)) l) else None ) | (Pexp_apply ( @@ -3527,9 +3526,9 @@ let printer = object(self:'self) *) let rec extract_apps args = function | { pmod_desc = Pmod_apply (m1, {pmod_desc=Pmod_ident loc}) } -> - let arg = String.concat "." (Longident.flatten loc.txt) in + let arg = String.concat "." (Longident.flatten_exn loc.txt) in extract_apps (arg :: args) m1 - | { pmod_desc=Pmod_ident loc } -> (String.concat "." (Longident.flatten loc.txt))::args + | { pmod_desc=Pmod_ident loc } -> (String.concat "." (Longident.flatten_exn loc.txt))::args | _ -> failwith "Functors in JSX tags support only module names as parameters" in let hasLabelledChildrenLiteral = List.exists (function | (Labelled "children", _) -> true @@ -3542,8 +3541,8 @@ let printer = object(self:'self) | _ :: rest -> hasSingleNonLabelledUnitAndIsAtTheEnd rest in if hasLabelledChildrenLiteral && hasSingleNonLabelledUnitAndIsAtTheEnd l then - if List.length (Longident.flatten loc.txt) > 1 then - if Longident.last loc.txt = "createElement" then + if List.length (Longident.flatten_exn loc.txt) > 1 then + if Longident.last_exn loc.txt = "createElement" then begin match extract_apps [] app with | ftor::args -> let applied = ftor ^ "(" ^ String.concat ", " args ^ ")" in @@ -3551,7 +3550,7 @@ let printer = object(self:'self) | _ -> None end else None - else Some (self#formatJSXComponent (Longident.last loc.txt) l) + else Some (self#formatJSXComponent (Longident.last_exn loc.txt) l) else None ) | _ -> None @@ -5229,9 +5228,9 @@ let printer = object(self:'self) *) method attachDocAttrsToLayout (* all std attributes attached on the ast node backing the layout *) - ~stdAttrs:(stdAttrs : Ast_411.Parsetree.attributes) + ~stdAttrs:(stdAttrs : Parsetree.attributes) (* all doc comments attached on the ast node backing the layout *) - ~docAttrs:(docAttrs : Ast_411.Parsetree.attributes) + ~docAttrs:(docAttrs : Parsetree.attributes) (* location of the layout *) ~loc (* layout to attach the doc comments to *) @@ -5254,7 +5253,7 @@ let printer = object(self:'self) | [] -> loc in let rec aux prevLoc layout = function - | ({ attr_name = x; _} as attr : Ast_411.Parsetree.attribute)::xs -> + | ({ attr_name = x; _} as attr : Parsetree.attribute)::xs -> let newLayout = let range = Range.makeRangeBetween x.loc prevLoc in let layout = @@ -5750,13 +5749,13 @@ let printer = object(self:'self) method patternRecord ?(wrap=("","")) l closed = let longident_x_pattern (li, p) = match (li, p.ppat_desc) with - | ({txt = ident}, Ppat_var {txt}) when Longident.last ident = txt -> + | ({txt = ident}, Ppat_var {txt}) when Longident.last_exn ident = txt -> (* record field punning when destructuring. {x: x, y: y} becomes {x, y} *) (* works with module prefix too: {MyModule.x: x, y: y} becomes {MyModule.x, y} *) self#longident_loc li | ({txt = ident}, Ppat_alias ({ppat_desc = (Ppat_var {txt = ident2}) }, {txt = aliasIdent})) - when Longident.last ident = ident2 -> + when Longident.last_exn ident = ident2 -> (* record field punning when destructuring with renaming. {state: state as prevState} becomes {state as prevState *) (* works with module prefix too: {ReasonReact.state: state as prevState} becomes {ReasonReact.state as prevState *) makeList ~sep:(Sep " ") [self#longident_loc li; atom "as"; atom aliasIdent] @@ -6112,7 +6111,7 @@ let printer = object(self:'self) (* record value punning. Turns {foo: foo, bar: 1} into {foo, bar: 1} *) (* also turns {Foo.bar: bar, baz: 1} into {Foo.bar, baz: 1} *) (* don't turn {bar: Foo.bar, baz: 1} into {bar, baz: 1}, naturally *) - | (Pexp_ident {txt = Lident value}, true, true) when Longident.last li.txt = value -> + | (Pexp_ident {txt = Lident value}, true, true) when Longident.last_exn li.txt = value -> makeList (maybeQuoteFirstElem li []) (* Force breaks for nested records or bs obj sugar @@ -6601,9 +6600,9 @@ let printer = object(self:'self) let pcd_loc = ed.pext_loc in let pcd_attributes = [] in let exn_arg = match ed.pext_kind with - | Pext_decl (args, type_opt) -> + | Pext_decl (vars, args, type_opt) -> let pcd_args, pcd_res = args, type_opt in - [self#type_variant_leaf_nobar {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes}] + [self#type_variant_leaf_nobar {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes; pcd_vars = vars}] | Pext_rebind id -> [atom pcd_name.txt; atom "="; (self#longident_loc id)] in let {stdAttrs; docAttrs} = @@ -7384,6 +7383,7 @@ let printer = object(self:'self) () | Psig_typesubst l -> self#type_def_list ~eq_symbol:":=" (Recursive, l) + | Psig_modtypesubst _ -> assert false in source_map ~loc:x.psig_loc item @@ -7504,6 +7504,7 @@ let printer = object(self:'self) destrAtom td | Pwith_modsubst (s, li2) -> modSub (self#longident s.txt) li2 ":=" + | Pwith_modtype (_, _)|Pwith_modtypesubst (_, _) -> assert false in (match l with | [] -> self#module_type ~space letPattern mt @@ -7542,9 +7543,9 @@ let printer = object(self:'self) formatPrecedence (self#module_type letPattern mt) | Pmod_structure s -> let wrap = if hug then - if s = [] then - ("(", ")") - else + if s = [] then + ("(", ")") + else ("({", "})") else ("{", "}") in let items = @@ -7584,7 +7585,7 @@ let printer = object(self:'self) method structure structureItems = (* We don't have any way to know if an extension is placed at the top level by the parsetree while there's a difference syntactically (% for structure_items/expressons and %% for top_level). - This small fn detects this particular case (structure > structure_item > extension > value) and + This small fn detects this particular case (structure > structure_item > extension > value) and prints with double % *) let structure_item item = match item.pstr_desc with @@ -7904,7 +7905,7 @@ let printer = object(self:'self) | [] -> [] | hd::tl -> let formattedHd = self#pattern hd in - let formattedHd = match hd.ppat_desc with + let formattedHd = match hd.ppat_desc with | Ppat_constraint _ -> formatPrecedence formattedHd | _ -> formattedHd in @@ -8111,7 +8112,7 @@ let printer = object(self:'self) *) let forceBreak = match funExpr.pexp_desc with | Pexp_ident ident when - let lastIdent = Longident.last ident.txt in + let lastIdent = Longident.last_exn ident.txt in List.mem lastIdent ["test"; "describe"; "it"; "expect"] -> true | _ -> false in @@ -8288,78 +8289,88 @@ let wrap_pat_with_tuple pat = * *) -module StringSet = Set.Make(String);; +module StringSet = Stdlib.Set.Make(String) let built_in_explicit_arity_constructors = ["Some"; "Assert_failure"; "Match_failure"] let explicit_arity_constructors = StringSet.of_list(built_in_explicit_arity_constructors @ (!configuredSettings).constructorLists) -let add_explicit_arity_mapper super = - let super_expr = super.Ast_mapper.expr in - let super_pat = super.Ast_mapper.pat in - let expr mapper expr = - let expr = - match expr with - | {pexp_desc=Pexp_construct(lid, Some sp); - pexp_loc; - pexp_attributes} when - List.exists - (fun c -> StringSet.mem c explicit_arity_constructors) - (longident_for_arity lid.txt) && - explicit_arity_not_exists pexp_attributes -> - {pexp_desc=Pexp_construct(lid, Some (wrap_expr_with_tuple sp)); - pexp_loc; - pexp_attributes=add_explicit_arity pexp_loc pexp_attributes; - pexp_loc_stack = []} - | x -> x - in - super_expr mapper expr - and pat mapper pat = - let pat = - match pat with - | {ppat_desc=Ppat_construct(lid, Some sp); - ppat_loc; - ppat_attributes} when - List.exists - (fun c -> StringSet.mem c explicit_arity_constructors) - (longident_for_arity lid.txt) && - explicit_arity_not_exists ppat_attributes -> - {ppat_desc=Ppat_construct(lid, Some (wrap_pat_with_tuple sp)); - ppat_loc; - ppat_attributes=add_explicit_arity ppat_loc ppat_attributes; - ppat_loc_stack = []} - | x -> x - in - super_pat mapper pat - in - { super with Ast_mapper. expr; pat } let preprocessing_mapper = - ml_to_reason_swap_operator_mapper - (escape_stars_slashes_mapper - (add_explicit_arity_mapper Ast_mapper.default_mapper)) + let escape_slashes = new Reason_syntax_util.escape_stars_slashes_mapper in + object + inherit Ast_traverse.map as super + + method! expression expr = + let expr = + match expr with + | {pexp_desc=Pexp_construct(lid, Some sp); + pexp_loc; + pexp_attributes} when + List.exists + (fun c -> StringSet.mem c explicit_arity_constructors) + (longident_for_arity lid.txt) && + explicit_arity_not_exists pexp_attributes -> + {pexp_desc=Pexp_construct(lid, Some (wrap_expr_with_tuple sp)); + pexp_loc; + pexp_attributes=add_explicit_arity pexp_loc pexp_attributes; + pexp_loc_stack = []} + | x -> x + in + escape_slashes#expression (super#expression expr) + + method! pattern pat = + let pat = + match pat with + | {ppat_desc=Ppat_construct(lid, Some (x, sp)); + ppat_loc; + ppat_attributes} when + List.exists + (fun c -> StringSet.mem c explicit_arity_constructors) + (longident_for_arity lid.txt) && + explicit_arity_not_exists ppat_attributes -> + {ppat_desc=Ppat_construct(lid, Some (x, wrap_pat_with_tuple sp)); + ppat_loc; + ppat_attributes=add_explicit_arity ppat_loc ppat_attributes; + ppat_loc_stack = []} + | x -> x + in + escape_slashes#pattern (super#pattern pat) + end + +let ml_to_reason_swap_operator_mapper = new Reason_syntax_util.ml_to_reason_swap_operator_mapper + +let preprocessing_mapper f a = + a + |> f ml_to_reason_swap_operator_mapper + |> f preprocessing_mapper let core_type ppf x = format_layout ppf - (printer#core_type (apply_mapper_to_type x preprocessing_mapper)) + (printer#core_type + (preprocessing_mapper apply_mapper_to_type x)) let pattern ppf x = format_layout ppf - (printer#pattern (apply_mapper_to_pattern x preprocessing_mapper)) + (printer#pattern + (preprocessing_mapper apply_mapper_to_pattern x)) let signature (comments : Comment.t list) ppf x = List.iter (fun comment -> printer#trackComment comment) comments; format_layout ppf ~comments - (printer#signature (apply_mapper_to_signature x preprocessing_mapper)) + (printer#signature + (preprocessing_mapper apply_mapper_to_signature x)) let structure (comments : Comment.t list) ppf x = List.iter (fun comment -> printer#trackComment comment) comments; format_layout ppf ~comments - (printer#structure (apply_mapper_to_structure x preprocessing_mapper)) + (printer#structure + (preprocessing_mapper apply_mapper_to_structure x)) let expression ppf x = format_layout ppf - (printer#unparseExpr (apply_mapper_to_expr x preprocessing_mapper)) + (printer#unparseExpr + (preprocessing_mapper apply_mapper_to_expr x)) let case_list = case_list diff --git a/src/reason-parser/reason_pprint_ast.mli b/src/reason-parser/reason_pprint_ast.mli index 932569e8f..513d2a1b9 100644 --- a/src/reason-parser/reason_pprint_ast.mli +++ b/src/reason-parser/reason_pprint_ast.mli @@ -1,5 +1,4 @@ -open Reason_omp -open Ast_411.Parsetree +open Ppxlib val configure : width:int -> @@ -7,11 +6,11 @@ val configure : val createFormatter : unit -> < - case_list : Format.formatter -> case list -> unit; - core_type : Format.formatter -> core_type -> unit; - expression : Format.formatter -> expression -> unit; - pattern : Format.formatter -> pattern -> unit; - signature : Reason_comment.t list -> Format.formatter -> signature -> unit; - structure : Reason_comment.t list -> Format.formatter -> structure -> unit; - toplevel_phrase : Format.formatter -> toplevel_phrase -> unit; + case_list : Format.formatter -> Parsetree.case list -> unit; + core_type : Format.formatter -> Parsetree.core_type -> unit; + expression : Format.formatter -> Parsetree.expression -> unit; + pattern : Format.formatter -> Parsetree.pattern -> unit; + signature : Reason_comment.t list -> Format.formatter -> Parsetree.signature -> unit; + structure : Reason_comment.t list -> Format.formatter -> Parsetree.structure -> unit; + toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit; > diff --git a/src/reason-parser/reason_syntax_util.cppo.ml b/src/reason-parser/reason_syntax_util.cppo.ml index 443ffe306..1caf38f44 100644 --- a/src/reason-parser/reason_syntax_util.cppo.ml +++ b/src/reason-parser/reason_syntax_util.cppo.ml @@ -14,11 +14,8 @@ patching the right parts, through the power of types(tm) *) -open Reason_omp -open Ast_411 - +open Ppxlib open Asttypes -open Ast_mapper open Parsetree open Longident @@ -403,19 +400,27 @@ let map_core_type f typ = | other -> other } +(* class supery= Ppxlib.Ast_traverse.map *) + (** identifier_mapper maps all identifiers in an AST with a mapping function f this is used by swap_operator_mapper right below, to traverse the whole AST and swapping the symbols listed above. *) -let identifier_mapper f super = -let map_fields fields = List.map(fun (lid,x) -> (map_lident f lid, x)) fields in -let map_name ({txt} as name) = {name with txt=(f txt)} in -let map_lid lid = map_lident f lid in -let map_label label = map_arg_label f label in -{ super with - expr = begin fun mapper expr -> - let expr = - match expr with + + +class identifier_mapper f = + + let map_fields fields = List.map(fun (lid,x) -> (map_lident f lid, x)) fields in + let map_name ({txt} as name) = {name with txt=(f txt)} in + let map_lid lid = map_lident f lid in + let map_label label = map_arg_label f label in + + object + inherit Ast_traverse.map as super + + method! expression (expr: Parsetree.expression) = + let expr = + match expr with | { pexp_desc = Pexp_ident lid } -> { expr with pexp_desc = Pexp_ident (map_lid lid) } | { pexp_desc = Pexp_fun (label, eo, pat, e) } when !rename_labels -> @@ -452,128 +457,125 @@ let map_label label = map_arg_label f label in { expr with pexp_desc = Pexp_newtype ({ s with txt = f s.txt }, e) } | _ -> expr - in - super.expr mapper expr - end; - pat = begin fun mapper pat -> - let pat = - match pat with - | { ppat_desc = Ppat_var name } -> - { pat with ppat_desc = Ppat_var (map_name name) } - | { ppat_desc = Ppat_alias (p, name) } -> - { pat with ppat_desc = Ppat_alias (p, map_name name) } - | { ppat_desc = Ppat_variant (s, po) } -> - { pat with - ppat_desc = Ppat_variant (f s, po) } - | { ppat_desc = Ppat_record (fields, closed) } when !rename_labels -> - { pat with - ppat_desc = Ppat_record (map_fields fields, closed) } - | { ppat_desc = Ppat_type lid } -> - { pat with ppat_desc = Ppat_type (map_lid lid) } - | _ -> pat - in - super.pat mapper pat - end; - value_description = begin fun mapper desc -> - let desc' = - { desc with - pval_name = map_name desc.pval_name } - in - super.value_description mapper desc' - end; - type_declaration = begin fun mapper type_decl -> - let type_decl' = - { type_decl with ptype_name = map_name type_decl.ptype_name } - in - let type_decl'' = match type_decl'.ptype_kind with - | Ptype_record lst when !rename_labels -> - { type_decl' - with ptype_kind = Ptype_record (List.map (fun lbl -> - { lbl with pld_name = map_name lbl.pld_name }) - lst) } - | _ -> type_decl' - in - super.type_declaration mapper type_decl'' - end; - typ = begin fun mapper typ -> - super.typ mapper (map_core_type f typ) - end; - class_declaration = begin fun mapper class_decl -> - let class_decl' = - { class_decl - with pci_name = map_name class_decl.pci_name - ; pci_expr = map_class_expr f class_decl.pci_expr - } - in - super.class_declaration mapper class_decl' - end; - class_field = begin fun mapper class_field -> - let class_field_desc' = match class_field.pcf_desc with - | Pcf_inherit (ovf, e, lo) -> - Pcf_inherit (ovf, map_class_expr f e, lo) - | Pcf_val (lbl, mut, kind) -> - Pcf_val ({lbl with txt = f lbl.txt}, mut, kind) - | Pcf_method (lbl, priv, kind) -> - Pcf_method ({lbl with txt = f lbl.txt}, priv, kind) - | x -> x - in - super.class_field mapper { class_field with pcf_desc = class_field_desc' } - end; - class_type_field = begin fun mapper class_type_field -> - let class_type_field_desc' = match class_type_field.pctf_desc with - | Pctf_inherit class_type -> - Pctf_inherit (map_class_type f class_type) - | Pctf_val (lbl, mut, vf, ct) -> - Pctf_val ({ lbl with txt = f lbl.txt }, mut, vf, ct) - | Pctf_method (lbl, pf, vf, ct) -> - Pctf_method ({ lbl with txt = f lbl.txt }, pf, vf, ct) - | x -> x - in - super.class_type_field mapper - { class_type_field - with pctf_desc = class_type_field_desc' } - end; - class_type_declaration = begin fun mapper class_type_decl -> - let class_type_decl' = - { class_type_decl - with pci_name = map_name class_type_decl.pci_name } - in - super.class_type_declaration mapper class_type_decl' - end; - module_type_declaration = begin fun mapper module_type_decl -> - let module_type_decl' = - { module_type_decl - with pmtd_name = map_name module_type_decl.pmtd_name } - in - super.module_type_declaration mapper module_type_decl' - end; -} - -let remove_stylistic_attrs_mapper_maker super = - let open Ast_411 in - let open Ast_mapper in -{ super with - expr = begin fun mapper expr -> - let {Reason_attributes.stylisticAttrs; arityAttrs; docAttrs; stdAttrs; jsxAttrs} = - Reason_attributes.partitionAttributes ~allowUncurry:false expr.pexp_attributes - in - let expr = if stylisticAttrs != [] then - { expr with pexp_attributes = arityAttrs @ docAttrs @ stdAttrs @ jsxAttrs } - else expr - in - super.expr mapper expr - end; - pat = begin fun mapper pat -> - let {Reason_attributes.stylisticAttrs; arityAttrs; docAttrs; stdAttrs; jsxAttrs} = - Reason_attributes.partitionAttributes ~allowUncurry:false pat.ppat_attributes - in - let pat = if stylisticAttrs != [] then - { pat with ppat_attributes = arityAttrs @ docAttrs @ stdAttrs @ jsxAttrs } - else pat - in - super.pat mapper pat - end; -} + in + super#expression expr + + method! pattern pat = + let pat = + match pat with + | { ppat_desc = Ppat_var name } -> + { pat with ppat_desc = Ppat_var (map_name name) } + | { ppat_desc = Ppat_alias (p, name) } -> + { pat with ppat_desc = Ppat_alias (p, map_name name) } + | { ppat_desc = Ppat_variant (s, po) } -> + { pat with + ppat_desc = Ppat_variant (f s, po) } + | { ppat_desc = Ppat_record (fields, closed) } when !rename_labels -> + { pat with + ppat_desc = Ppat_record (map_fields fields, closed) } + | { ppat_desc = Ppat_type lid } -> + { pat with ppat_desc = Ppat_type (map_lid lid) } + | _ -> pat + in + super#pattern pat + + method! value_description desc = + let desc' = + { desc with + pval_name = map_name desc.pval_name } + in + super#value_description desc' + + method! type_declaration type_decl = + let type_decl' = + { type_decl with ptype_name = map_name type_decl.ptype_name } + in + let type_decl'' = match type_decl'.ptype_kind with + | Ptype_record lst when !rename_labels -> + { type_decl' + with ptype_kind = Ptype_record (List.map (fun lbl -> + { lbl with pld_name = map_name lbl.pld_name }) + lst) } + | _ -> type_decl' + in + super#type_declaration type_decl'' + + method! core_type typ = super#core_type (map_core_type f typ) + + method! class_declaration class_decl = + let class_decl' = + { class_decl + with pci_name = map_name class_decl.pci_name + ; pci_expr = map_class_expr f class_decl.pci_expr + } + in + super#class_declaration class_decl' + + method! class_field class_field = + let class_field_desc' = match class_field.pcf_desc with + | Pcf_inherit (ovf, e, lo) -> + Pcf_inherit (ovf, map_class_expr f e, lo) + | Pcf_val (lbl, mut, kind) -> + Pcf_val ({lbl with txt = f lbl.txt}, mut, kind) + | Pcf_method (lbl, priv, kind) -> + Pcf_method ({lbl with txt = f lbl.txt}, priv, kind) + | x -> x + in + super#class_field { class_field with pcf_desc = class_field_desc' } + + method! class_type_field class_type_field = + let class_type_field_desc' = match class_type_field.pctf_desc with + | Pctf_inherit class_type -> + Pctf_inherit (map_class_type f class_type) + | Pctf_val (lbl, mut, vf, ct) -> + Pctf_val ({ lbl with txt = f lbl.txt }, mut, vf, ct) + | Pctf_method (lbl, pf, vf, ct) -> + Pctf_method ({ lbl with txt = f lbl.txt }, pf, vf, ct) + | x -> x + in + super#class_type_field + { class_type_field + with pctf_desc = class_type_field_desc' } + + method! class_type_declaration class_type_decl = + let class_type_decl' = + { class_type_decl + with pci_name = map_name class_type_decl.pci_name } + in + super#class_type_declaration class_type_decl' + + method! module_type_declaration module_type_decl = + let module_type_decl' = + { module_type_decl + with pmtd_name = map_name module_type_decl.pmtd_name } + in + super#module_type_declaration module_type_decl' + end + +let remove_stylistic_attrs_mapper_maker = + object + inherit Ast_traverse.map as super + + method! expression expr = + let {Reason_attributes.stylisticAttrs; arityAttrs; docAttrs; stdAttrs; jsxAttrs} = + Reason_attributes.partitionAttributes ~allowUncurry:false expr.pexp_attributes + in + let expr = if stylisticAttrs != [] then + { expr with pexp_attributes = arityAttrs @ docAttrs @ stdAttrs @ jsxAttrs } + else expr + in + super#expression expr + + method! pattern pat = + let {Reason_attributes.stylisticAttrs; arityAttrs; docAttrs; stdAttrs; jsxAttrs} = + Reason_attributes.partitionAttributes ~allowUncurry:false pat.ppat_attributes + in + let pat = if stylisticAttrs != [] then + { pat with ppat_attributes = arityAttrs @ docAttrs @ stdAttrs @ jsxAttrs } + else pat + in + super#pattern pat + end let escape_stars_slashes str = if String.contains str '/' then @@ -585,7 +587,7 @@ let escape_stars_slashes str = str let remove_stylistic_attrs_mapper = - remove_stylistic_attrs_mapper_maker Ast_mapper.default_mapper + remove_stylistic_attrs_mapper_maker let let_monad_symbols = [ '$'; '&'; '*'; '+'; '-'; '/'; '<'; '='; '>'; '@'; '^'; '|'; '.'; '!'] @@ -625,16 +627,8 @@ let is_andop s = #endif #if OCAML_VERSION >= (4, 8, 0) -let noop_mapper super = - let noop = fun _mapper x -> x in - { super with - expr = noop; - structure = noop; - structure_item = noop; - signature = noop; - signature_item = noop; } (* Don't need to backport past 4.08 *) -let backport_letopt_mapper = noop_mapper +let backport_letopt_mapper = new Ast_traverse.map let expand_letop_identifier s = s let compress_letop_identifier s = s #else @@ -728,64 +722,70 @@ let compress_letop_identifier s = s * * (let+)((and+)(y, b), ((x, a)) => x + a) *) -let backport_letopt_mapper super = - let open Ast_411 in - let open Ast_mapper in -{ super with - expr = fun mapper expr -> - match expr.pexp_desc with - | Pexp_letop { let_; ands; body } -> - (* coalesce the initial 'let' and any subsequent 'and's into a final - Pattern (for the argument of the continuation function) and - Expression (the first arg ot the let function) - - let+ a = b - and+ c = d - and+ e = f - and+ g = h - - produces the pattern (a, (c, (e, g))) - and the expression (and+)(b, (and+)(d, (and+)(f, h))) - *) - let rec loop = function - | [] -> assert false - | {pbop_op; pbop_pat; pbop_exp}::[] -> (pbop_pat, pbop_exp, pbop_op) - | {pbop_op; pbop_pat; pbop_exp; pbop_loc}::rest -> - let (pattern, expr, op) = loop rest in - let and_op_ident = Ast_helper.Exp.ident - ~loc:op.loc - (Location.mkloc (Longident.Lident op.txt) op.loc) - in - ( - Ast_helper.Pat.tuple ~loc:pbop_loc [pbop_pat; pattern], - Ast_helper.Exp.apply ~loc:pbop_loc and_op_ident [(Nolabel, pbop_exp); (Nolabel, expr)], - pbop_op - ) - in - let (pattern, expr, _) = loop (let_::ands) in - let let_op_ident = Ast_helper.Exp.ident - ~loc:let_.pbop_op.loc - (Location.mkloc (Longident.Lident let_.pbop_op.txt) let_.pbop_op.loc) - in - super.expr mapper {expr with - pexp_desc = Pexp_apply (let_op_ident, [ - (Nolabel, expr); - (Nolabel, Ast_helper.Exp.fun_ ~loc:let_.pbop_loc Nolabel None pattern body) - ])} - | _ -> super.expr mapper expr -} +let backport_letopt_mapper = + object + inherit Ast_traverse.map as super + + method! expression expr = + match expr.pexp_desc with + | Pexp_letop { let_; ands; body } -> + (* coalesce the initial 'let' and any subsequent 'and's into a final + Pattern (for the argument of the continuation function) and + Expression (the first arg ot the let function) + + let+ a = b + and+ c = d + and+ e = f + and+ g = h + + produces the pattern (a, (c, (e, g))) + and the expression (and+)(b, (and+)(d, (and+)(f, h))) + *) + let rec loop = function + | [] -> assert false + | {pbop_op; pbop_pat; pbop_exp}::[] -> (pbop_pat, pbop_exp, pbop_op) + | {pbop_op; pbop_pat; pbop_exp; pbop_loc}::rest -> + let (pattern, expr, op) = loop rest in + let and_op_ident = Ast_helper.Exp.ident + ~loc:op.loc + {Location.txt = (Longident.Lident op.txt); loc = op.loc} + in + ( + Ast_helper.Pat.tuple ~loc:pbop_loc [pbop_pat; pattern], + Ast_helper.Exp.apply ~loc:pbop_loc and_op_ident [(Nolabel, pbop_exp); (Nolabel, expr)], + pbop_op + ) + in + let (pattern, expr, _) = loop (let_::ands) in + let let_op_ident = Ast_helper.Exp.ident + ~loc:let_.pbop_op.loc + { Location.txt = (Longident.Lident let_.pbop_op.txt); loc = let_.pbop_op.loc } + in + super#expression {expr with + pexp_desc = Pexp_apply (let_op_ident, [ + (Nolabel, expr); + (Nolabel, Ast_helper.Exp.fun_ ~loc:let_.pbop_loc Nolabel None pattern body) + ])} + | _ -> super#expression expr + end #endif (** escape_stars_slashes_mapper escapes all stars and slashes in an AST *) -let escape_stars_slashes_mapper = identifier_mapper escape_stars_slashes +class escape_stars_slashes_mapper = object + inherit identifier_mapper escape_stars_slashes +end (* To be used in parser, transform a token into an ast node with different identifier *) -let reason_to_ml_swap_operator_mapper = identifier_mapper reason_to_ml_swap +class reason_to_ml_swap_operator_mapper = object + inherit identifier_mapper reason_to_ml_swap +end (* To be used in printer, transform an ast node into a token with different identifier *) -let ml_to_reason_swap_operator_mapper = identifier_mapper ml_to_reason_swap +class ml_to_reason_swap_operator_mapper = object + inherit identifier_mapper ml_to_reason_swap +end (* attribute_equals tests an attribute is txt *) @@ -809,19 +809,19 @@ let normalized_attributes attribute attributes = List.filter (fun x -> not (attribute_equals attribute x)) attributes (* apply_mapper family applies an ast_mapper to an ast *) -let apply_mapper_to_structure s mapper = mapper.structure mapper s -let apply_mapper_to_signature s mapper = mapper.signature mapper s -let apply_mapper_to_type s mapper = mapper.typ mapper s -let apply_mapper_to_expr s mapper = mapper.expr mapper s -let apply_mapper_to_pattern s mapper = mapper.pat mapper s +let apply_mapper_to_structure mapper s= mapper#structure s +let apply_mapper_to_signature mapper s= mapper#signature s +let apply_mapper_to_type mapper s= mapper#core_type s +let apply_mapper_to_expr mapper s= mapper#expression s +let apply_mapper_to_pattern mapper s= mapper#pattern s -let apply_mapper_to_toplevel_phrase toplevel_phrase mapper = +let apply_mapper_to_toplevel_phrase mapper toplevel_phrase = match toplevel_phrase with - | Ptop_def x -> Ptop_def (apply_mapper_to_structure x mapper) + | Ptop_def x -> Ptop_def (apply_mapper_to_structure mapper x) | x -> x -let apply_mapper_to_use_file use_file mapper = - List.map (fun x -> apply_mapper_to_toplevel_phrase x mapper) use_file +let apply_mapper_to_use_file mapper use_file = + List.map (fun x -> apply_mapper_to_toplevel_phrase mapper x) use_file let map_first f = function | [] -> invalid_arg "Syntax_util.map_first: empty list" @@ -842,11 +842,11 @@ let location_contains loc1 loc2 = loc1.loc_end.Lexing.pos_cnum >= loc2.loc_end.Lexing.pos_cnum #if OCAML_VERSION >= (4, 8, 0) -let split_compiler_error (err : Location.error) = - (err.main.loc, Format.asprintf "%t" err.main.txt) +let split_compiler_error (err : Location.Error.t) = + (Location.Error.get_location err, Format.asprintf "%s" (Location.Error.message err)) #else -let split_compiler_error (err : Location.error) = - (err.loc, err.msg) +let split_compiler_error (err : Location.Error.t) = + (Location.Error.get_location err, Location.Error.message err) #endif let explode_str str = @@ -856,7 +856,7 @@ let explode_str str = loop [] (String.length str - 1) module Clflags = struct - include Clflags + include Ocaml_common.Clflags #if OCAML_VERSION >= (4, 8, 0) let fast = unsafe @@ -865,7 +865,12 @@ end let parse_lid s = #if OCAML_VERSION >= (4, 6, 0) - match Longident.unflatten (String.split_on_char '.' s) with + let unflatten l = + match l with + | [] -> None + | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl) + in + match unflatten (String.split_on_char '.' s) with | Some lid -> lid | None -> failwith (Format.asprintf "parse_lid: unable to parse '%s' to longident" s) #else diff --git a/src/reason-parser/reason_syntax_util.cppo.mli b/src/reason-parser/reason_syntax_util.cppo.mli index 155d685fb..9c9e2fff6 100644 --- a/src/reason-parser/reason_syntax_util.cppo.mli +++ b/src/reason-parser/reason_syntax_util.cppo.mli @@ -13,7 +13,7 @@ BuckleScript; ping @chenglou and a few others and we'll keep them synced up by patching the right parts, through the power of types(tm) *) -open Reason_omp.Ast_411 +open Ppxlib val ml_to_reason_swap : string -> string @@ -34,25 +34,22 @@ val processLineEndingsAndStarts : string -> string val isLineComment : string -> bool -val remove_stylistic_attrs_mapper : Ast_mapper.mapper +val remove_stylistic_attrs_mapper : Ast_traverse.map val is_letop : string -> bool val is_andop : string -> bool val compress_letop_identifier : string -> string val expand_letop_identifier : string -> string -val backport_letopt_mapper : Ast_mapper.mapper -> Ast_mapper.mapper +val backport_letopt_mapper : Ast_traverse.map val escape_stars_slashes : string -> string -val escape_stars_slashes_mapper : - Ast_mapper.mapper -> Ast_mapper.mapper +class escape_stars_slashes_mapper : Ast_traverse.map -val reason_to_ml_swap_operator_mapper : - Ast_mapper.mapper -> Ast_mapper.mapper +class reason_to_ml_swap_operator_mapper : Ast_traverse.map -val ml_to_reason_swap_operator_mapper : - Ast_mapper.mapper -> Ast_mapper.mapper +class ml_to_reason_swap_operator_mapper : Ast_traverse.map val attribute_exists : string -> Parsetree.attributes -> bool @@ -62,25 +59,27 @@ val attributes_conflicted : val normalized_attributes : string -> Parsetree.attributes -> Parsetree.attributes val apply_mapper_to_structure : - Parsetree.structure -> Ast_mapper.mapper -> Parsetree.structure + Ast_traverse.map -> Parsetree.structure -> Parsetree.structure val apply_mapper_to_signature : - Parsetree.signature -> Ast_mapper.mapper -> Parsetree.signature + Ast_traverse.map -> Parsetree.signature -> Parsetree.signature val apply_mapper_to_type : - Parsetree.core_type -> Ast_mapper.mapper -> Parsetree.core_type + Ast_traverse.map -> Parsetree.core_type -> Parsetree.core_type val apply_mapper_to_expr : - Parsetree.expression -> Ast_mapper.mapper -> Parsetree.expression + Ast_traverse.map -> Parsetree.expression -> Parsetree.expression val apply_mapper_to_pattern : - Parsetree.pattern -> Ast_mapper.mapper -> Parsetree.pattern + Ast_traverse.map -> Parsetree.pattern -> Parsetree.pattern val apply_mapper_to_toplevel_phrase : - Parsetree.toplevel_phrase -> Ast_mapper.mapper -> Parsetree.toplevel_phrase + Ast_traverse.map -> Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase -val apply_mapper_to_use_file : Parsetree.toplevel_phrase list -> - Ast_mapper.mapper -> Parsetree.toplevel_phrase list +val apply_mapper_to_use_file + : Ast_traverse.map + -> Parsetree.toplevel_phrase list + -> Parsetree.toplevel_phrase list val map_first : ('a -> 'a) -> 'a list -> 'a list @@ -90,12 +89,12 @@ val location_is_before : Location.t -> Location.t -> bool val location_contains : Location.t -> Location.t -> bool -val split_compiler_error : Location.error -> Location.t * string +val split_compiler_error : Location.Error.t -> Location.t * string val explode_str : string -> char list module Clflags : sig - include module type of Clflags + include module type of Ocaml_common.Clflags #if OCAML_VERSION >= (4, 8, 0) val fast : bool ref diff --git a/src/reason-parser/reason_toolchain.ml b/src/reason-parser/reason_toolchain.ml index 73b00aeed..8c53b1efb 100644 --- a/src/reason-parser/reason_toolchain.ml +++ b/src/reason-parser/reason_toolchain.ml @@ -79,8 +79,7 @@ *) open Reason_toolchain_conf -open Reason_omp -open Ast_411 +open Ppxlib open Location open Lexing @@ -285,7 +284,7 @@ module Create_parse_entrypoint (Toolchain_impl: Toolchain_spec) :Toolchain = str Reason_errors.report_error Format.str_formatter ~loc e; (loc, Format.flush_str_formatter ()) | exn -> - (Location.curr lexbuf, "default_error: " ^ Printexc.to_string exn) + (Location.of_lexbuf lexbuf, "default_error: " ^ Printexc.to_string exn) in (loc, Reason_errors.error_extension_node loc msg) else diff --git a/src/reason-parser/reason_toolchain_conf.ml b/src/reason-parser/reason_toolchain_conf.ml index 2b7cc1c19..afb1ef87a 100644 --- a/src/reason-parser/reason_toolchain_conf.ml +++ b/src/reason-parser/reason_toolchain_conf.ml @@ -1,8 +1,13 @@ -open Reason_omp -include Ast_411 +open Ppxlib -module From_current = Convert(OCaml_current)(OCaml_411) -module To_current = Convert(OCaml_411)(OCaml_current) +module From_current = struct + include Ppxlib.Selected_ast.Of_ocaml + include Reason_omp.Convert (Reason_omp.OCaml_current) (Reason_omp.OCaml_414) +end +module To_current = struct + include Ppxlib.Selected_ast.To_ocaml + include Reason_omp.Convert (Reason_omp.OCaml_414) (Reason_omp.OCaml_current) +end module type Toolchain = sig (* Parsing *) diff --git a/src/reason-parser/reason_toolchain_ocaml.ml b/src/reason-parser/reason_toolchain_ocaml.ml index e37a7ddfb..57cda180e 100644 --- a/src/reason-parser/reason_toolchain_ocaml.ml +++ b/src/reason-parser/reason_toolchain_ocaml.ml @@ -1,24 +1,28 @@ +open Ppxlib open Reason_toolchain_conf (* The OCaml parser keep doc strings in the comment list. To avoid duplicating comments, we need to filter comments that appear as doc strings is the AST out of the comment list. *) let doc_comments_filter () = - let open Ast_mapper in let open Parsetree in let seen = Hashtbl.create 7 in - let attribute mapper = function - | { attr_name = { Location. txt = ("ocaml.doc" | "ocaml.text")}; - attr_payload = - PStr [{ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string(_text, _loc, None)) } , _); - pstr_loc = loc }]} as attribute -> - (* Workaround: OCaml 4.02.3 kept an initial '*' in docstrings. - * For other versions, we have to put the '*' back. *) - Hashtbl.add seen loc (); - default_mapper.attribute mapper attribute - | attribute -> default_mapper.attribute mapper attribute + let mapper = + object + inherit Ast_traverse.map as super + method! attribute attr = + match attr with + | { attr_name = { Location. txt = ("ocaml.doc" | "ocaml.text")}; + attr_payload = + PStr [{ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string(_text, _loc, None)) } , _); + pstr_loc = loc }]} as attribute -> + (* Workaround: OCaml 4.02.3 kept an initial '*' in docstrings. + * For other versions, we have to put the '*' back. *) + Hashtbl.add seen loc (); + super#attribute attribute + | attribute -> super#attribute attribute + end in - let mapper = {default_mapper with attribute} in let filter (_text, loc) = not (Hashtbl.mem seen loc) in (mapper, filter) @@ -33,7 +37,7 @@ module Lexer_impl = struct filtered_comments := List.filter filter (Lexer.comments ()) let get_comments _lexbuf _docstrings = !filtered_comments end -module OCaml_parser = Parser +module OCaml_parser = Ocaml_common.Parser type token = OCaml_parser.token type invalid_docstrings = unit @@ -49,34 +53,34 @@ let parse_and_filter_doc_comments iter fn lexbuf= let implementation lexbuf = parse_and_filter_doc_comments - (fun it -> it.Ast_mapper.structure it) + (fun it stru -> it#structure stru) (fun lexbuf -> From_current.copy_structure - (Parser.implementation Lexer.token lexbuf)) + (OCaml_parser.implementation Lexer.token lexbuf)) lexbuf let core_type lexbuf = parse_and_filter_doc_comments - (fun it -> it.Ast_mapper.typ it) + (fun it ty -> it#core_type ty) (fun lexbuf -> From_current.copy_core_type - (Parser.parse_core_type Lexer.token lexbuf)) + (OCaml_parser.parse_core_type Lexer.token lexbuf)) lexbuf let interface lexbuf = parse_and_filter_doc_comments - (fun it -> it.Ast_mapper.signature it) + (fun it sig_ -> it#signature sig_) (fun lexbuf -> From_current.copy_signature - (Parser.interface Lexer.token lexbuf)) + (OCaml_parser.interface Lexer.token lexbuf)) lexbuf let filter_toplevel_phrase it = function - | Parsetree.Ptop_def str -> ignore (it.Ast_mapper.structure it str) + | Parsetree.Ptop_def str -> ignore (it#structure str) | Parsetree.Ptop_dir _ -> () let toplevel_phrase lexbuf = parse_and_filter_doc_comments filter_toplevel_phrase (fun lexbuf -> From_current.copy_toplevel_phrase - (Parser.toplevel_phrase Lexer.token lexbuf)) + (OCaml_parser.toplevel_phrase Lexer.token lexbuf)) lexbuf let use_file lexbuf = @@ -85,7 +89,7 @@ let use_file lexbuf = (fun lexbuf -> List.map From_current.copy_toplevel_phrase - (Parser.use_file Lexer.token lexbuf)) + (OCaml_parser.use_file Lexer.token lexbuf)) lexbuf (* Skip tokens to the end of the phrase *) @@ -109,6 +113,8 @@ let maybe_skip_phrase lexbuf = then () else skip_phrase lexbuf +module Location = Ocaml_common.Location + let safeguard_parsing lexbuf fn = try fn () with @@ -132,15 +138,16 @@ let safeguard_parsing lexbuf fn = (* Unfortunately we drop the comments because there doesn't exist an ML * printer that formats comments *and* line wrapping! (yet) *) let format_interface_with_comments (signature, _) formatter = - Pprintast.signature formatter + Ocaml_common.Pprintast.signature formatter (To_current.copy_signature signature) + let format_implementation_with_comments (structure, _) formatter = let structure = - Reason_syntax_util.(apply_mapper_to_structure - structure - (backport_letopt_mapper remove_stylistic_attrs_mapper)) + structure + |> Reason_syntax_util.(apply_mapper_to_structure backport_letopt_mapper) + |> Reason_syntax_util.(apply_mapper_to_structure remove_stylistic_attrs_mapper) in - Pprintast.structure formatter + Ocaml_common.Pprintast.structure formatter (To_current.copy_structure structure) module Lexer = Lexer_impl diff --git a/src/reason-parser/reason_toolchain_reason.ml b/src/reason-parser/reason_toolchain_reason.ml index 1a6c4dcf2..ca4623fd1 100644 --- a/src/reason-parser/reason_toolchain_reason.ml +++ b/src/reason-parser/reason_toolchain_reason.ml @@ -1,4 +1,3 @@ -open Reason_toolchain_conf open Reason_errors module P = Reason_recover_parser diff --git a/src/refmt/printer_maker.ml b/src/refmt/printer_maker.ml index b7eb108f5..b938cb482 100644 --- a/src/refmt/printer_maker.ml +++ b/src/refmt/printer_maker.ml @@ -1,5 +1,3 @@ -open Reason_omp - type parse_itype = [ `ML | `Reason | `Binary | `BinaryReason | `Auto ] type print_itype = [ `ML | `Reason | `Binary | `BinaryReason | `AST | `None ] @@ -36,22 +34,16 @@ let close_output_file output_file output_chan = | None -> () let ocamlBinaryParser use_stdin filename = - let chan = + let module Ast_io = Ppxlib__.Utils.Ast_io in + let input_source = match use_stdin with - | true -> stdin - | false -> - let file_chan = open_in_bin filename in - seek_in file_chan 0; - file_chan + | true -> Ast_io.Stdin + | false -> File filename in - match Ast_io.from_channel chan with + match Ast_io.read input_source ~input_kind:Necessarily_binary with | Error _ -> assert false - | Ok (_, Ast_io.Impl ((module Version), ast)) -> - let module Convert = Convert(Version)(OCaml_411) in - ((Obj.magic (Convert.copy_structure ast), []), true, false) - | Ok (_, Ast_io.Intf ((module Version), ast)) -> - let module Convert = Convert(Version)(OCaml_411) in - ((Obj.magic (Convert.copy_signature ast), []), true, true) + | Ok ({ ast = Impl ast; _ }) -> ((Obj.magic ast, []), true, false) + | Ok ({ ast = Intf ast; _ }) -> ((Obj.magic ast, []), true, true) let reasonBinaryParser use_stdin filename = let chan = diff --git a/src/refmt/reason_implementation_printer.ml b/src/refmt/reason_implementation_printer.ml index 8f49f8a07..11b0e6b6d 100644 --- a/src/refmt/reason_implementation_printer.ml +++ b/src/refmt/reason_implementation_printer.ml @@ -1,5 +1,4 @@ -open Reason_omp -open Ast_411 +open Ppxlib type t = Parsetree.structure let err = Printer_maker.err @@ -46,18 +45,24 @@ let print printtype filename parsedAsML output_chan output_formatter = * interface file. *) output_value output_chan ( - Config.ast_impl_magic_number, filename, ast, comments, parsedAsML, false + Ocaml_common.Config.ast_impl_magic_number, filename, ast, comments, parsedAsML, false ); ) | `Binary -> fun (ast, _) -> let ast = - Reason_syntax_util.(apply_mapper_to_structure ast (backport_letopt_mapper remove_stylistic_attrs_mapper)) + ast + |> Reason_syntax_util.(apply_mapper_to_structure remove_stylistic_attrs_mapper) + |> Reason_syntax_util.(apply_mapper_to_structure backport_letopt_mapper) in - Ast_io.to_channel output_chan filename - (Ast_io.Impl ((module OCaml_current), - Reason_toolchain.To_current.copy_structure ast)) + Ppxlib__.Utils.Ast_io.write + output_chan + { Ppxlib__.Utils.Ast_io.input_name = filename; + input_version = Obj.magic (module Ppxlib_ast.Compiler_version: Ppxlib_ast.OCaml_version); + ast = Impl ast + } + ~add_ppx_context:false | `AST -> fun (ast, _) -> ( - Printast.implementation output_formatter + Ocaml_common.Printast.implementation output_formatter (Reason_toolchain.To_current.copy_structure ast) ) | `None -> (fun _ -> ()) diff --git a/src/refmt/reason_interface_printer.ml b/src/refmt/reason_interface_printer.ml index bcd2c5078..8aaf9b2ea 100644 --- a/src/refmt/reason_interface_printer.ml +++ b/src/refmt/reason_interface_printer.ml @@ -1,5 +1,4 @@ -open Reason_omp -open Ast_411 +open Ppxlib type t = Parsetree.signature let err = Printer_maker.err @@ -45,19 +44,25 @@ let print printtype filename parsedAsML output_chan output_formatter = * interface file. *) output_value output_chan ( - Config.ast_intf_magic_number, filename, ast, comments, parsedAsML, true + Ocaml_common.Config.ast_intf_magic_number, filename, ast, comments, parsedAsML, true ); ) | `Binary -> fun (ast, _) -> ( let ast = - Reason_syntax_util.(apply_mapper_to_signature ast (backport_letopt_mapper remove_stylistic_attrs_mapper)) + ast + |> Reason_syntax_util.(apply_mapper_to_signature remove_stylistic_attrs_mapper) + |> Reason_syntax_util.(apply_mapper_to_signature backport_letopt_mapper) in - Ast_io.to_channel output_chan filename - (Ast_io.Intf ((module OCaml_current), - Reason_toolchain.To_current.copy_signature ast)) + Ppxlib__.Utils.Ast_io.write + output_chan + { Ppxlib__.Utils.Ast_io.input_name = filename; + input_version = Obj.magic (module Ppxlib_ast.Compiler_version: Ppxlib_ast.OCaml_version); + ast = Intf ast + } + ~add_ppx_context:false ) | `AST -> fun (ast, _) -> ( - Printast.interface output_formatter + Ocaml_common.Printast.interface output_formatter (Reason_toolchain.To_current.copy_signature ast) ) | `None -> (fun _ -> ()) diff --git a/src/vendored-omp/src/ast_402.ml b/src/vendored-omp/src/ast_402.ml index 036cdf05a..ae0c43311 100644 --- a/src/vendored-omp/src/ast_402.ml +++ b/src/vendored-omp/src/ast_402.ml @@ -60,2572 +60,6 @@ module Asttypes = struct | Invariant end -module Parsetree = struct - (** Abstract syntax tree produced by parsing *) - - open Asttypes - - (** {2 Extension points} *) - - type attribute = string loc * payload - (* [@id ARG] - [@@id ARG] - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - - and extension = string loc * payload - (* [%id ARG] - [%%id ARG] - - Sub-language placeholder -- rejected by the typechecker. - *) - - and attributes = attribute list - - and payload (*IF_CURRENT = Parsetree.payload *) = - | PStr of structure - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - - (** {2 Core language} *) - - (* Type expressions *) - - and core_type (*IF_CURRENT = Parsetree.core_type *) = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) - | Ptyp_arrow of label * core_type * core_type - (* T1 -> T2 (label = "") - ~l:T1 -> T2 (label = "l") - ?l:T1 -> T2 (label = "?l") - *) - | Ptyp_tuple of core_type list - (* T1 * ... * Tn - - Invariant: n >= 2 - *) - | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of (string * attributes * core_type) list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string list * core_type - (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). - - - As the core_type of a Pctf_method node. - - - As the core_type of a Pexp_poly node. - - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) - - and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) - - and row_field (*IF_CURRENT = Parsetree.row_field *) = - | Rtag of label * attributes * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 2nd field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - - - TODO: switch to a record representation, and keep location - *) - | Rinherit of core_type - (* [ T ] *) - - (* Patterns *) - - and pattern (*IF_CURRENT = Parsetree.pattern *) = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Ppat_interval of constant * constant - (* 'a'..'z' - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (* (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Ppat_construct of Longident.t loc * pattern option - (* C None - C P Some P - C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) - *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) - | Ppat_unpack of string loc - (* (module P) - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - - (* Value expressions *) - - and expression (*IF_CURRENT = Parsetree.expression *) = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = - | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of label * expression option * pattern * expression - (* fun P -> E1 (lab = "", None) - fun ~l:P -> E1 (lab = "l", None) - fun ?l:P -> E1 (lab = "?l", None) - fun ?l:(P = E0) -> E1 (lab = "?l", Some E0) - - Notes: - - If E0 is provided, lab must start with '?'. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) - | Pexp_apply of expression * (label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_tuple of expression list - (* (E1, ..., En) - - Invariant: n >= 2 - *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) - | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) - | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * string - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of string loc * expression - (* x <- 2 *) - | Pexp_override of (string loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) - | Pexp_letmodule of string loc * module_expr * expression - (* let module M = ME in E *) - | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) - | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string * expression - (* fun (type t) -> E *) - | Pexp_pack of module_expr - (* (module ME) - - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of override_flag * Longident.t loc * expression - (* let open M in E - let! open M in E - *) - | Pexp_extension of extension - (* [%id] *) - - and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - - (* Value descriptions *) - - and value_description (*IF_CURRENT = Parsetree.value_description *) = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } - - (* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) - - Note: when used under Pstr_primitive, prim cannot be empty - *) - - (* Type declarations *) - - and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = - { - ptype_name: string loc; - ptype_params: (core_type * variance) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } - - (* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) - *) - - and type_kind (*IF_CURRENT = Parsetree.type_kind *) = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - (* Invariant: non-empty list *) - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) - | Ptype_open - - and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l [@id1] [@id2] : T *) - } - - (* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. - *) - - and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = - { - pcd_name: string loc; - pcd_args: core_type list; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C [@id1] [@id2] of ... *) - } - (* - | C of T1 * ... * Tn (res = None) - | C: T0 (args = [], res = Some T0) - | C: T1 * ... * Tn -> T0 (res = Some T0) - *) - - and type_extension (*IF_CURRENT = Parsetree.type_extension *) = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * variance) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* - type t += ... - *) - - and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C [@id1] [@id2] of ... *) - } - - and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = - Pext_decl of core_type list * core_type option - (* - | C of T1 * ... * Tn ([T1; ...; Tn], None) - | C: T0 ([], Some T0) - | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) - *) - | Pext_rebind of Longident.t loc - (* - | C = D - *) - - (** {2 Class language} *) - - (* Type expressions for the class language *) - - and class_type (*IF_CURRENT = Parsetree.class_type *) = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = - | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) - | Pcty_arrow of label * core_type * class_type - (* T -> CT (label = "") - ~l:T -> CT (label = "l") - ?l:T -> CT (label = "?l") - *) - | Pcty_extension of extension - (* [%id] *) - - and class_signature (*IF_CURRENT = Parsetree.class_signature *) = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } - (* object('selfpat) ... end - object ... end (self = Ptyp_any) - *) - - and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = - | Pctf_inherit of class_type - (* inherit CT *) - | Pctf_val of (string * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (string * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) - - and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = - { - pci_virt: virtual_flag; - pci_params: (core_type * variance) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... - - Also used for "class type" declaration. - *) - - and class_description = class_type class_infos - - and class_type_declaration = class_type class_infos - - (* Value expressions for the class language *) - - and class_expr (*IF_CURRENT = Parsetree.class_expr *) = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = - | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) - | Pcl_fun of label * expression option * pattern * class_expr - (* fun P -> CE (lab = "", None) - fun ~l:P -> CE (lab = "l", None) - fun ?l:P -> CE (lab = "?l", None) - fun ?l:(P = E0) -> CE (lab = "?l", Some E0) - *) - | Pcl_apply of class_expr * (label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - - and class_structure (*IF_CURRENT = Parsetree.class_structure *) = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } - (* object(selfpat) ... end - object ... end (self = Ppat_any) - *) - - and class_field (*IF_CURRENT = Parsetree.class_field *) = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_field_desc (*IF_CURRENT = Parsetree.class_field_desc *) = - | Pcf_inherit of override_flag * class_expr * string option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) - | Pcf_val of (string loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) - | Pcf_method of (string loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) - - and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - - and class_declaration = class_expr class_infos - - (** {2 Module language} *) - - (* Type expressions for the module language *) - - and module_type (*IF_CURRENT = Parsetree.module_type *) = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) - | Pmty_functor of string loc * module_type option * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) - - and signature = signature_item list - - and signature_item (*IF_CURRENT = Parsetree.signature_item *) = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - - and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = - | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) - | Psig_type of type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of extension_constructor - (* exception C of T *) - | Psig_module of module_declaration - (* module X : MT *) - | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) - | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) - | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) - - and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = - { - pmd_name: string loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } - (* S : MT *) - - and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } - (* S = MT - S (abstract module type declaration, pmtd_type = None) - *) - - and open_description (*IF_CURRENT = Parsetree.open_description *) = - { - popen_lid: Longident.t loc; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } - (* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) - - and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - - and include_description = module_type include_infos - (* include MT *) - - and include_declaration = module_expr include_infos - (* include ME *) - - and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = - | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) - | Pwith_typesubst of type_declaration - (* with type t := ... *) - | Pwith_modsubst of string loc * Longident.t loc - (* with module X := Z *) - - (* Value expressions for the module language *) - - and module_expr (*IF_CURRENT = Parsetree.module_expr *) = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) - | Pmod_functor of string loc * module_type option * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) - - and structure = structure_item list - - and structure_item (*IF_CURRENT = Parsetree.structure_item *) = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - - and structure_item_desc (*IF_CURRENT = Parsetree.structure_item_desc *) = - | Pstr_eval of expression * attributes - (* E *) - | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) - | Pstr_primitive of value_description - (* external x: T = "s1" ... "sn" *) - | Pstr_type of type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) - | Pstr_exception of extension_constructor - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) - | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_description - (* open X *) - | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) - | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) - - and value_binding (*IF_CURRENT = Parsetree.value_binding *) = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - - and module_binding (*IF_CURRENT = Parsetree.module_binding *) = - { - pmb_name: string loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } - (* X = ME *) - - (** {2 Toplevel} *) - - (* Toplevel phrases *) - - type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = - | Ptop_def of structure - | Ptop_dir of string * directive_argument - (* #use, #load ... *) - - and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = - | Pdir_none - | Pdir_string of string - | Pdir_int of int - | Pdir_ident of Longident.t - | Pdir_bool of bool -end - -module Docstrings : sig - (** {3 Docstrings} *) - - (** Documentation comments *) - type docstring - - (** Create a docstring *) - val docstring : string -> Location.t -> docstring - - (** Get the text of a docstring *) - val docstring_body : docstring -> string - - (** Get the location of a docstring *) - val docstring_loc : docstring -> Location.t - - (** {3 Items} - - The {!docs} type represents documentation attached to an item. *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - val empty_docs : docs - - val docs_attr : docstring -> Parsetree.attribute - - (** Convert item documentation to attributes and add them to an - attribute list *) - val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - - (** {3 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - - type info = docstring option - - val empty_info : info - - val info_attr : docstring -> Parsetree.attribute - - (** Convert field info to attributes and add them to an - attribute list *) - val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - - (** {3 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - - type text = docstring list - - val empty_text : text - - val text_attr : docstring -> Parsetree.attribute - - (** Convert text to attributes and add them to an attribute list *) - val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - -end = struct - open Location - - (* Docstrings *) - - type docstring = - { ds_body: string; - ds_loc: Location.t; } - - (* Docstring constructors and destructors *) - - let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; } - in - ds - - let docstring_body ds = ds.ds_body - - let docstring_loc ds = ds.ds_loc - - (* Docstrings attached to items *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - let empty_docs = { docs_pre = None; docs_post = None } - - let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - - let docs_attr ds = - let open Asttypes in - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Const_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (doc_loc, PStr [item]) - - let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - - (* Docstrings attached to constructors or fields *) - - type info = docstring option - - let empty_info = None - - let info_attr = docs_attr - - let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - - (* Docstrings not attached to a specific item *) - - type text = docstring list - - let empty_text = [] - - let text_loc = {txt = "ocaml.text"; loc = Location.none} - - let text_attr ds = - let open Asttypes in - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Const_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (text_loc, PStr [item]) - - let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""; _} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - -end - -module Ast_helper : sig - (** Helpers to produce Parsetree fragments *) - - open Parsetree - open Asttypes - open Docstrings - - type lid = Longident.t loc - type str = string loc - type loc = Location.t - type attrs = attribute list - - (** {2 Default locations} *) - - val default_loc: loc ref - (** Default value for all optional location arguments. *) - - val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - - (** {2 Core language} *) - - (** Type expressions *) - module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> - (string * attributes * core_type) list -> closed_flag -> - core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> string list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - end - - (** Patterns *) - module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - - (** Expressions *) - module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> pattern - -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> string -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> string -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - - val case: pattern -> ?guard:expression -> expression -> case - end - - (** Value declarations *) - module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - - (** Type declarations *) - module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * variance) list -> ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?args:core_type list -> ?res:core_type -> str -> constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - - (** Type extensions *) - module Te: - sig - val mk: ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * variance) list -> ?priv:private_flag -> - lid -> extension_constructor list -> type_extension - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?args:core_type list -> ?res:core_type -> str -> extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - - (** {2 Module language} *) - - (** Module type expressions *) - module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - - (** Module expressions *) - module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - - (** Signature items *) - module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> extension_constructor -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - - (** Structure items *) - module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> extension_constructor -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_description -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - - (** Module declarations *) - module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_type -> module_declaration - end - - (** Module type declarations *) - module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - - (** Module bindings *) - module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_expr -> module_binding - end - - (* Opens *) - module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> lid -> open_description - end - - (* Includes *) - module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - - (** Value bindings *) - - module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - - (** {2 Class language} *) - - (** Class type expressions *) - module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> label -> core_type -> class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - end - - (** Class type fields *) - module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> string -> mutable_flag -> virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> string -> private_flag -> virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - - (** Class expressions *) - module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> label -> expression option -> pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> (label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - end - - (** Class fields *) - module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> string option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - - (** Classes *) - module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> ?params:(core_type * variance) list -> - str -> 'a -> 'a class_infos - end - - (** Class signatures *) - module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - - (** Class structures *) - module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - -end = struct - (** Helpers to produce Parsetree fragments *) - - open Asttypes - open Parsetree - open Docstrings - - type lid = Longident.t loc - type str = string loc - type loc = Location.t - type attrs = attribute list - - let default_loc = ref Location.none - - let with_default_loc l f = - let old = !default_loc in - default_loc := l; - try let r = f () in default_loc := old; r - with exn -> default_loc := old; raise exn - - module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - end - - module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) - end - - module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - end - - module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) - end - - module Mod = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg arg_ty body = - mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) - end - - module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc a = mk ?loc (Psig_type a) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - txt - end - - module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc a = mk ?loc (Pstr_type a) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - txt - end - - module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - end - - module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - end - - module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - - end - - module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - - end - - module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } - end - - module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } - end - - module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } - end - - module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } - end - - module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) lid = - { - popen_lid = lid; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } - end - - module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - - end - - module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } - end - - module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } - end - - module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(args = []) ?res name = - { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - - end - - (** Type extensions *) - module Te = struct - let mk ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) ?(args = []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - end - - module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } - end - - module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } - end - -end - -module Ast_mapper : sig - (** The interface of a -ppx rewriter - - A -ppx rewriter is a program that accepts a serialized abstract syntax - tree and outputs another, possibly modified, abstract syntax tree. - This module encapsulates the interface between the compiler and - the -ppx rewriters, handling such details as the serialization format, - forwarding of command-line flags, and storing state. - - {!mapper} allows to implement AST rewriting using open recursion. - A typical mapper would be based on {!default_mapper}, a deep - identity mapper, and will fall back on it for handling the syntax it - does not modify. For example: - - {[ - open Asttypes - open Parsetree - open Ast_mapper - - let test_mapper argv = - { default_mapper with - expr = fun mapper expr -> - match expr with - | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> - Ast_helper.Exp.constant (Const_int 42) - | other -> default_mapper.expr mapper other; } - - let () = - register "ppx_test" test_mapper]} - - This -ppx rewriter, which replaces [[%test]] in expressions with - the constant [42], can be compiled using - [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. - - *) - - open Parsetree - - (** {2 A generic Parsetree mapper} *) - - type mapper (*IF_CURRENT = Ast_mapper.mapper*) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - (** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - - val default_mapper: mapper - (** A default mapper, which implements a "deep identity" mapping. *) - - (** {2 Convenience functions to write mappers} *) - - val map_opt: ('a -> 'b) -> 'a option -> 'b option - - val extension_of_error: Locations.location_error -> extension - (** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) - - val attribute_of_warning: Location.t -> string -> attribute - (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) - - include Locations.Helpers_intf - -end = struct - (* A generic Parsetree mapping class *) - - (* - [@@@ocaml.warning "+9"] - (* Ensure that record patterns don't miss any field. *) - *) - - - open Parsetree - open Ast_helper - open Location - - type mapper (*IF_CURRENT = Ast_mapper.mapper*) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - - let map_fst f (x, y) = (f x, y) - let map_snd f (x, y) = (x, f y) - let map_tuple f1 f2 (x, y) = (f1 x, f2 y) - let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) - let map_opt f = function None -> None | Some x -> Some (f x) - - let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - - module T = struct - (* Type expressions for the core language *) - - let row_field sub = function - | Rtag (l, attrs, b, tl) -> - Rtag (l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - let f (s, a, t) = (s, sub.attributes sub a, sub.typ sub t) in - object_ ~loc ~attrs (List.map f l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs sl (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - Type.mk (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - ~loc:(sub.location sub ptype_loc) - ~attrs:(sub.attributes sub ptype_attributes) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_attributes} = - Te.mk - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - ~attrs:(sub.attributes sub ptyext_attributes) - - let map_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - Pext_decl(List.map (sub.typ sub) ctl, map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - Te.constructor - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - ~loc:(sub.location sub pext_loc) - ~attrs:(sub.attributes sub pext_attributes) - - end - - module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) - end - - module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (s, mt1, mt2) -> - functor_ ~loc ~attrs (map_loc sub s) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) mt1) - (sub.module_type sub mt2) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_typesubst d -> Pwith_typesubst (sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type l -> type_ ~loc (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) - end - - - module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (arg, arg_ty, body) -> - functor_ ~loc ~attrs (map_loc sub arg) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) arg_ty) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type l -> type_ ~loc (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_description sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) - end - - module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs x - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) s - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> newtype ~loc ~attrs s (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (ovf, lid, e) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - end - - module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs c - | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) - end - - module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub.class_expr sub ce) s - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - Ci.mk - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) - ~loc:(sub.location sub pci_loc) - ~attrs:(sub.attributes sub pci_attributes) - end - - (* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - - let default_mapper = - { - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_description = - (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_lid) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~args:(List.map (this.typ this) pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - - let extension_of_error (error : Locations.location_error) : extension = - Locations.extension_of_error - ~mk_pstr:(function - | x :: l -> PStr (x :: x :: l) - | l -> PStr l) - ~mk_extension:(fun x -> Str.extension x) - ~mk_string_constant:(fun x -> Str.eval (Exp.constant (Asttypes.Const_string (x, None)))) - error - - let attribute_of_warning loc s = - { loc; txt = "ocaml.ppwarning" }, - PStr ([Str.eval ~loc (Exp.constant (Asttypes.Const_string (s, None)))]) - - include Locations.Helpers_impl - -end - module Outcometree = struct (* Module [Outcometree]: results displayed by the toplevel *) @@ -2742,110 +176,3 @@ module Outcometree = struct | Ophr_exception of (exn * out_value) end - -module Config = struct - let ast_impl_magic_number = "Caml1999M016" - let ast_intf_magic_number = "Caml1999N015" -end - -let map_signature mapper = mapper.Ast_mapper.signature mapper -let map_structure mapper = mapper.Ast_mapper.structure mapper - -let shallow_identity = - let id _ x = x in - { - Ast_mapper. - structure = id; - structure_item = id; - module_expr = id; - signature = id; - signature_item = id; - module_type = id; - with_constraint = id; - class_declaration = id; - class_expr = id; - class_field = id; - class_structure = id; - class_type = id; - class_type_field = id; - class_signature = id; - class_type_declaration = id; - class_description = id; - type_declaration = id; - type_kind = id; - typ = id; - type_extension = id; - extension_constructor = id; - value_description = id; - pat = id; - expr = id; - module_declaration = id; - module_type_declaration = id; - module_binding = id; - open_description = id; - include_description = id; - include_declaration = id; - value_binding = id; - constructor_declaration = id; - label_declaration = id; - cases = id; - case = id; - location = id; - extension = id; - attribute = id; - attributes = id; - payload = id; - } - -let failing_mapper = - let fail _ _ = - invalid_arg "failing_mapper: this mapper function should never get called" - in - { - Ast_mapper. - structure = fail; - structure_item = fail; - module_expr = fail; - signature = fail; - signature_item = fail; - module_type = fail; - with_constraint = fail; - class_declaration = fail; - class_expr = fail; - class_field = fail; - class_structure = fail; - class_type = fail; - class_type_field = fail; - class_signature = fail; - class_type_declaration = fail; - class_description = fail; - type_declaration = fail; - type_kind = fail; - typ = fail; - type_extension = fail; - extension_constructor = fail; - value_description = fail; - pat = fail; - expr = fail; - module_declaration = fail; - module_type_declaration = fail; - module_binding = fail; - open_description = fail; - include_description = fail; - include_declaration = fail; - value_binding = fail; - constructor_declaration = fail; - label_declaration = fail; - cases = fail; - case = fail; - location = fail; - extension = fail; - attribute = fail; - attributes = fail; - payload = fail; - } - -let make_top_mapper ~signature ~structure = - {failing_mapper with Ast_mapper. - signature = (fun _ x -> signature x); - structure = (fun _ x -> structure x) } diff --git a/src/vendored-omp/src/ast_403.ml b/src/vendored-omp/src/ast_403.ml index 800c36187..f2f6f859a 100644 --- a/src/vendored-omp/src/ast_403.ml +++ b/src/vendored-omp/src/ast_403.ml @@ -66,2654 +66,6 @@ module Asttypes = struct | Invariant end -module Parsetree = struct - (** Abstract syntax tree produced by parsing *) - - open Asttypes - - type constant (*IF_CURRENT = Parsetree.constant *) = - Pconst_integer of string * char option - (* 3 3l 3L 3n - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker - *) - | Pconst_char of char - (* 'c' *) - | Pconst_string of string * string option - (* "constant" - {delim|other constant|delim} - *) - | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - - (** {2 Extension points} *) - - type attribute = string loc * payload - (* [@id ARG] - [@@id ARG] - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - - and extension = string loc * payload - (* [%id ARG] - [%%id ARG] - - Sub-language placeholder -- rejected by the typechecker. - *) - - and attributes = attribute list - - and payload (*IF_CURRENT = Parsetree.payload *) = - | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - - (** {2 Core language} *) - - (* Type expressions *) - - and core_type (*IF_CURRENT = Parsetree.core_type *) = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Otional - *) - | Ptyp_tuple of core_type list - (* T1 * ... * Tn - - Invariant: n >= 2 - *) - | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of (string * attributes * core_type) list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string list * core_type - (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). - - - As the core_type of a Pctf_method node. - - - As the core_type of a Pexp_poly node. - - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) - - and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) - - and row_field (*IF_CURRENT = Parsetree.row_field *) = - | Rtag of label * attributes * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 2nd field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - - - TODO: switch to a record representation, and keep location - *) - | Rinherit of core_type - (* [ T ] *) - - (* Patterns *) - - and pattern (*IF_CURRENT = Parsetree.pattern *) = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Ppat_interval of constant * constant - (* 'a'..'z' - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (* (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Ppat_construct of Longident.t loc * pattern option - (* C None - C P Some P - C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) - *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) - | Ppat_unpack of string loc - (* (module P) - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - - (* Value expressions *) - - and expression (*IF_CURRENT = Parsetree.expression *) = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = - | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) - | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_tuple of expression list - (* (E1, ..., En) - - Invariant: n >= 2 - *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) - | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) - | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * string - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of string loc * expression - (* x <- 2 *) - | Pexp_override of (string loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) - | Pexp_letmodule of string loc * module_expr * expression - (* let module M = ME in E *) - | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) - | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string * expression - (* fun (type t) -> E *) - | Pexp_pack of module_expr - (* (module ME) - - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of override_flag * Longident.t loc * expression - (* let open M in E - let! open M in E - *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable - (* . *) - - and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - - (* Value descriptions *) - - and value_description (*IF_CURRENT = Parsetree.value_description *) = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } - - (* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) - *) - - (* Type declarations *) - - and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = - { - ptype_name: string loc; - ptype_params: (core_type * variance) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } - - (* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) - *) - - and type_kind (*IF_CURRENT = Parsetree.type_kind *) = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - (* Invariant: non-empty list *) - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) - | Ptype_open - - and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l [@id1] [@id2] : T *) - } - - (* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. - *) - - and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = - { - pcd_name: string loc; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C [@id1] [@id2] of ... *) - } - - and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - - (* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) - *) - - and type_extension (*IF_CURRENT = Parsetree.type_extension *) = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * variance) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* - type t += ... - *) - - and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C [@id1] [@id2] of ... *) - } - - and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = - Pext_decl of constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([T1; ...; Tn], None) - | C: T0 ([], Some T0) - | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) - *) - | Pext_rebind of Longident.t loc - (* - | C = D - *) - - (** {2 Class language} *) - - (* Type expressions for the class language *) - - and class_type (*IF_CURRENT = Parsetree.class_type *) = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = - | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) - | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - - and class_signature (*IF_CURRENT = Parsetree.class_signature *) = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } - (* object('selfpat) ... end - object ... end (self = Ptyp_any) - *) - - and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = - | Pctf_inherit of class_type - (* inherit CT *) - | Pctf_val of (string * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (string * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) - - and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = - { - pci_virt: virtual_flag; - pci_params: (core_type * variance) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... - - Also used for "class type" declaration. - *) - - and class_description = class_type class_infos - - and class_type_declaration = class_type class_infos - - (* Value expressions for the class language *) - - and class_expr (*IF_CURRENT = Parsetree.class_expr *) = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = - | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - - and class_structure (*IF_CURRENT = Parsetree.class_structure *) = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } - (* object(selfpat) ... end - object ... end (self = Ppat_any) - *) - - and class_field (*IF_CURRENT = Parsetree.class_field *) = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_field_desc (*IF_CURRENT = Parsetree.class_field_desc *) = - | Pcf_inherit of override_flag * class_expr * string option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) - | Pcf_val of (string loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) - | Pcf_method of (string loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) - - and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - - and class_declaration = class_expr class_infos - - (** {2 Module language} *) - - (* Type expressions for the module language *) - - and module_type (*IF_CURRENT = Parsetree.module_type *) = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) - | Pmty_functor of string loc * module_type option * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) - - and signature = signature_item list - - and signature_item (*IF_CURRENT = Parsetree.signature_item *) = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - - and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = - | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) - | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of extension_constructor - (* exception C of T *) - | Psig_module of module_declaration - (* module X : MT *) - | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) - | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) - | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) - - and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = - { - pmd_name: string loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } - (* S : MT *) - - and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } - (* S = MT - S (abstract module type declaration, pmtd_type = None) - *) - - and open_description (*IF_CURRENT = Parsetree.open_description *) = - { - popen_lid: Longident.t loc; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } - (* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) - - and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - - and include_description = module_type include_infos - (* include MT *) - - and include_declaration = module_expr include_infos - (* include ME *) - - and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = - | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) - | Pwith_typesubst of type_declaration - (* with type t := ... *) - | Pwith_modsubst of string loc * Longident.t loc - (* with module X := Z *) - - (* Value expressions for the module language *) - - and module_expr (*IF_CURRENT = Parsetree.module_expr *) = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) - | Pmod_functor of string loc * module_type option * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) - - and structure = structure_item list - - and structure_item (*IF_CURRENT = Parsetree.structure_item *) = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - - and structure_item_desc (*IF_CURRENT = Parsetree.structure_item_desc *) = - | Pstr_eval of expression * attributes - (* E *) - | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) - | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) - | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) - | Pstr_exception of extension_constructor - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) - | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_description - (* open X *) - | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) - | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) - - and value_binding (*IF_CURRENT = Parsetree.value_binding *) = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - - and module_binding (*IF_CURRENT = Parsetree.module_binding *) = - { - pmb_name: string loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } - (* X = ME *) - - (** {2 Toplevel} *) - - (* Toplevel phrases *) - - type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = - | Ptop_def of structure - | Ptop_dir of string * directive_argument - (* #use, #load ... *) - - and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = - | Pdir_none - | Pdir_string of string - | Pdir_int of string * char option - | Pdir_ident of Longident.t - | Pdir_bool of bool -end - -module Docstrings : sig - (** {3 Docstrings} *) - - (** Documentation comments *) - type docstring - - (** Create a docstring *) - val docstring : string -> Location.t -> docstring - - (** Get the text of a docstring *) - val docstring_body : docstring -> string - - (** Get the location of a docstring *) - val docstring_loc : docstring -> Location.t - - (** {3 Items} - - The {!docs} type represents documentation attached to an item. *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - val empty_docs : docs - - val docs_attr : docstring -> Parsetree.attribute - - (** Convert item documentation to attributes and add them to an - attribute list *) - val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - - (** {3 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - - type info = docstring option - - val empty_info : info - - val info_attr : docstring -> Parsetree.attribute - - (** Convert field info to attributes and add them to an - attribute list *) - val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - - (** {3 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - - type text = docstring list - - val empty_text : text - - val text_attr : docstring -> Parsetree.attribute - - (** Convert text to attributes and add them to an attribute list *) - val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - -end = struct - open Location - - (* Docstrings *) - - type docstring = - { ds_body: string; - ds_loc: Location.t; } - - (* Docstring constructors and destructors *) - - let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; } - in - ds - - let docstring_body ds = ds.ds_body - - let docstring_loc ds = ds.ds_loc - - (* Docstrings attached to items *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - let empty_docs = { docs_pre = None; docs_post = None } - - let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - - let docs_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (doc_loc, PStr [item]) - - let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - - (* Docstrings attached to constructors or fields *) - - type info = docstring option - - let empty_info = None - - let info_attr = docs_attr - - let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - - (* Docstrings not attached to a specific item *) - - type text = docstring list - - let empty_text = [] - - let text_loc = {txt = "ocaml.text"; loc = Location.none} - - let text_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (text_loc, PStr [item]) - - let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""; _} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - -end - -module Ast_helper : sig - (** Helpers to produce Parsetree fragments *) - - open Asttypes - open Docstrings - open Parsetree - - type lid = Longident.t loc - type str = string loc - type loc = Location.t - type attrs = attribute list - - (** {2 Default locations} *) - - val default_loc: loc ref - (** Default value for all optional location arguments. *) - - val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - - (** {2 Constants} *) - - module Const : sig - val char : char -> constant - val string : ?quotation_delimiter:string -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant - end - - (** {2 Core language} *) - - (** Type expressions *) - module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> - (string * attributes * core_type) list -> closed_flag -> - core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> string list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - end - - (** Patterns *) - module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - - (** Expressions *) - module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> string -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> string -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression - -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - end - - (** Value declarations *) - module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - - (** Type declarations *) - module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * variance) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - - (** Type extensions *) - module Te: - sig - val mk: ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * variance) list -> ?priv:private_flag -> - lid -> extension_constructor list -> type_extension - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - - (** {2 Module language} *) - - (** Module type expressions *) - module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - - (** Module expressions *) - module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - - (** Signature items *) - module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> extension_constructor -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - - (** Structure items *) - module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> extension_constructor -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_description -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - - (** Module declarations *) - module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_type -> module_declaration - end - - (** Module type declarations *) - module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - - (** Module bindings *) - module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_expr -> module_binding - end - - (* Opens *) - module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> lid -> open_description - end - - (* Includes *) - module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - - (** Value bindings *) - - module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - - (** {2 Class language} *) - - (** Class type expressions *) - module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - end - - (** Class type fields *) - module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> string -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> string -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - - (** Class expressions *) - module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - end - - (** Class fields *) - module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - string option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - - (** Classes *) - module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> ?params:(core_type * variance) list -> - str -> 'a -> 'a class_infos - end - - (** Class signatures *) - module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - - (** Class structures *) - module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - -end = struct - (** Helpers to produce Parsetree fragments *) - - open Asttypes - open Parsetree - open Docstrings - - type lid = Longident.t loc - type str = string loc - type loc = Location.t - type attrs = attribute list - - let default_loc = ref Location.none - - let with_default_loc l f = - let old = !default_loc in - default_loc := l; - try let r = f () in default_loc := old; r - with exn -> default_loc := old; raise exn - - module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (string_of_int i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) - end - - module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - end - - module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) - end - - module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - end - - module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) - end - - module Mod = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg arg_ty body = - mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) - end - - module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - txt - end - - module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - txt - end - - module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - end - - module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - end - - module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - - end - - module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - - end - - module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } - end - - module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } - end - - module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } - end - - module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } - end - - module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) lid = - { - popen_lid = lid; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } - end - - module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - - end - - module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } - end - - module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } - end - - module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - - end - - (** Type extensions *) - module Te = struct - let mk ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - end - - module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } - end - - module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } - end - -end - -module Ast_mapper : sig - (** The interface of a -ppx rewriter - - A -ppx rewriter is a program that accepts a serialized abstract syntax - tree and outputs another, possibly modified, abstract syntax tree. - This module encapsulates the interface between the compiler and - the -ppx rewriters, handling such details as the serialization format, - forwarding of command-line flags, and storing state. - - {!mapper} allows to implement AST rewriting using open recursion. - A typical mapper would be based on {!default_mapper}, a deep - identity mapper, and will fall back on it for handling the syntax it - does not modify. For example: - - {[ - open Asttypes - open Parsetree - open Ast_mapper - - let test_mapper argv = - { default_mapper with - expr = fun mapper expr -> - match expr with - | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> - Ast_helper.Exp.constant (Const_int 42) - | other -> default_mapper.expr mapper other; } - - let () = - register "ppx_test" test_mapper]} - - This -ppx rewriter, which replaces [[%test]] in expressions with - the constant [42], can be compiled using - [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. - - *) - - open Parsetree - - (** {2 A generic Parsetree mapper} *) - - type mapper (*IF_CURRENT = Ast_mapper.mapper*) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - (** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - - val default_mapper: mapper - (** A default mapper, which implements a "deep identity" mapping. *) - - (** {2 Convenience functions to write mappers} *) - - val map_opt: ('a -> 'b) -> 'a option -> 'b option - - val extension_of_error: Locations.location_error -> extension - (** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) - - val attribute_of_warning: Location.t -> string -> attribute - (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) - - include Locations.Helpers_intf - -end = struct - (* A generic Parsetree mapping class *) - - (* - [@@@ocaml.warning "+9"] - (* Ensure that record patterns don't miss any field. *) - *) - - - open Parsetree - open Ast_helper - open Location - - type mapper (*IF_CURRENT = Ast_mapper.mapper*) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - - let map_fst f (x, y) = (f x, y) - let map_snd f (x, y) = (x, f y) - let map_tuple f1 f2 (x, y) = (f1 x, f2 y) - let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) - let map_opt f = function None -> None | Some x -> Some (f x) - - let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - - module T = struct - (* Type expressions for the core language *) - - let row_field sub = function - | Rtag (l, attrs, b, tl) -> - Rtag (l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - let f (s, a, t) = (s, sub.attributes sub a, sub.typ sub t) in - object_ ~loc ~attrs (List.map f l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs sl (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - Type.mk (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - ~loc:(sub.location sub ptype_loc) - ~attrs:(sub.attributes sub ptype_attributes) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_attributes} = - Te.mk - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - ~attrs:(sub.attributes sub ptyext_attributes) - - let map_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - Te.constructor - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - ~loc:(sub.location sub pext_loc) - ~attrs:(sub.attributes sub pext_attributes) - - end - - module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) - end - - module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (s, mt1, mt2) -> - functor_ ~loc ~attrs (map_loc sub s) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) mt1) - (sub.module_type sub mt2) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_typesubst d -> Pwith_typesubst (sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) - end - - - module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (arg, arg_ty, body) -> - functor_ ~loc ~attrs (map_loc sub arg) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) arg_ty) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_description sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) - end - - module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs x - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) s - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> newtype ~loc ~attrs s (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (ovf, lid, e) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () - end - - module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs c - | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) - end - - module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub.class_expr sub ce) s - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - Ci.mk - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) - ~loc:(sub.location sub pci_loc) - ~attrs:(sub.attributes sub pci_attributes) - end - - (* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - - let default_mapper = - { - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_description = - (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_lid) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - - let extension_of_error (error : Locations.location_error) : extension = - Locations.extension_of_error - ~mk_pstr:(function - | x :: l -> PStr (x :: x :: l) - | l -> PStr l) - ~mk_extension:(fun x -> Str.extension x) - ~mk_string_constant:(fun x -> Str.eval (Exp.constant (Pconst_string (x, None)))) - error - - let attribute_of_warning loc s = - { loc; txt = "ocaml.ppwarning" }, - PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, None)))]) - - include Locations.Helpers_impl - -end - module Outcometree = struct (* Module [Outcometree]: results displayed by the toplevel *) @@ -2841,110 +193,3 @@ module Outcometree = struct | Ophr_exception of (exn * out_value) end - -module Config = struct - let ast_impl_magic_number = "Caml1999M019" - let ast_intf_magic_number = "Caml1999N018" -end - -let map_signature mapper = mapper.Ast_mapper.signature mapper -let map_structure mapper = mapper.Ast_mapper.structure mapper - -let shallow_identity = - let id _ x = x in - { - Ast_mapper. - structure = id; - structure_item = id; - module_expr = id; - signature = id; - signature_item = id; - module_type = id; - with_constraint = id; - class_declaration = id; - class_expr = id; - class_field = id; - class_structure = id; - class_type = id; - class_type_field = id; - class_signature = id; - class_type_declaration = id; - class_description = id; - type_declaration = id; - type_kind = id; - typ = id; - type_extension = id; - extension_constructor = id; - value_description = id; - pat = id; - expr = id; - module_declaration = id; - module_type_declaration = id; - module_binding = id; - open_description = id; - include_description = id; - include_declaration = id; - value_binding = id; - constructor_declaration = id; - label_declaration = id; - cases = id; - case = id; - location = id; - extension = id; - attribute = id; - attributes = id; - payload = id; - } - -let failing_mapper = - let fail _ _ = - invalid_arg "failing_mapper: this mapper function should never get called" - in - { - Ast_mapper. - structure = fail; - structure_item = fail; - module_expr = fail; - signature = fail; - signature_item = fail; - module_type = fail; - with_constraint = fail; - class_declaration = fail; - class_expr = fail; - class_field = fail; - class_structure = fail; - class_type = fail; - class_type_field = fail; - class_signature = fail; - class_type_declaration = fail; - class_description = fail; - type_declaration = fail; - type_kind = fail; - typ = fail; - type_extension = fail; - extension_constructor = fail; - value_description = fail; - pat = fail; - expr = fail; - module_declaration = fail; - module_type_declaration = fail; - module_binding = fail; - open_description = fail; - include_description = fail; - include_declaration = fail; - value_binding = fail; - constructor_declaration = fail; - label_declaration = fail; - cases = fail; - case = fail; - location = fail; - extension = fail; - attribute = fail; - attributes = fail; - payload = fail; - } - -let make_top_mapper ~signature ~structure = - {failing_mapper with Ast_mapper. - signature = (fun _ x -> signature x); - structure = (fun _ x -> structure x) } diff --git a/src/vendored-omp/src/ast_404.ml b/src/vendored-omp/src/ast_404.ml index 21874d11b..a47445820 100644 --- a/src/vendored-omp/src/ast_404.ml +++ b/src/vendored-omp/src/ast_404.ml @@ -66,2671 +66,6 @@ module Asttypes = struct | Invariant end -module Parsetree = struct - (** Abstract syntax tree produced by parsing *) - - open Asttypes - - type constant (*IF_CURRENT = Parsetree.constant *) = - Pconst_integer of string * char option - (* 3 3l 3L 3n - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker - *) - | Pconst_char of char - (* 'c' *) - | Pconst_string of string * string option - (* "constant" - {delim|other constant|delim} - *) - | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - - (** {2 Extension points} *) - - type attribute = string loc * payload - (* [@id ARG] - [@@id ARG] - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - - and extension = string loc * payload - (* [%id ARG] - [%%id ARG] - - Sub-language placeholder -- rejected by the typechecker. - *) - - and attributes = attribute list - - and payload (*IF_CURRENT = Parsetree.payload *) = - | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - - (** {2 Core language} *) - - (* Type expressions *) - - and core_type (*IF_CURRENT = Parsetree.core_type *) = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Otional - *) - | Ptyp_tuple of core_type list - (* T1 * ... * Tn - - Invariant: n >= 2 - *) - | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of (string * attributes * core_type) list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string list * core_type - (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). - - - As the core_type of a Pctf_method node. - - - As the core_type of a Pexp_poly node. - - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) - - and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) - - and row_field (*IF_CURRENT = Parsetree.row_field *) = - | Rtag of label * attributes * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 2nd field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - - - TODO: switch to a record representation, and keep location - *) - | Rinherit of core_type - (* [ T ] *) - - (* Patterns *) - - and pattern (*IF_CURRENT = Parsetree.pattern *) = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Ppat_interval of constant * constant - (* 'a'..'z' - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (* (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Ppat_construct of Longident.t loc * pattern option - (* C None - C P Some P - C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) - *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) - | Ppat_unpack of string loc - (* (module P) - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of Longident.t loc * pattern - - (* Value expressions *) - - and expression (*IF_CURRENT = Parsetree.expression *) = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = - | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) - | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_tuple of expression list - (* (E1, ..., En) - - Invariant: n >= 2 - *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) - | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) - | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * string - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of string loc * expression - (* x <- 2 *) - | Pexp_override of (string loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) - | Pexp_letmodule of string loc * module_expr * expression - (* let module M = ME in E *) - | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) - | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) - | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string * expression - (* fun (type t) -> E *) - | Pexp_pack of module_expr - (* (module ME) - - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of override_flag * Longident.t loc * expression - (* let open M in E - let! open M in E - *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable - (* . *) - - and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - - (* Value descriptions *) - - and value_description (*IF_CURRENT = Parsetree.value_description *) = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } - - (* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) - *) - - (* Type declarations *) - - and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = - { - ptype_name: string loc; - ptype_params: (core_type * variance) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } - - (* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) - *) - - and type_kind (*IF_CURRENT = Parsetree.type_kind *) = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - (* Invariant: non-empty list *) - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) - | Ptype_open - - and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l [@id1] [@id2] : T *) - } - - (* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. - *) - - and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = - { - pcd_name: string loc; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C [@id1] [@id2] of ... *) - } - - and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - - (* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) - *) - - and type_extension (*IF_CURRENT = Parsetree.type_extension *) = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * variance) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* - type t += ... - *) - - and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C [@id1] [@id2] of ... *) - } - - and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = - Pext_decl of constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([T1; ...; Tn], None) - | C: T0 ([], Some T0) - | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) - *) - | Pext_rebind of Longident.t loc - (* - | C = D - *) - - (** {2 Class language} *) - - (* Type expressions for the class language *) - - and class_type (*IF_CURRENT = Parsetree.class_type *) = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = - | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) - | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - - and class_signature (*IF_CURRENT = Parsetree.class_signature *) = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } - (* object('selfpat) ... end - object ... end (self = Ptyp_any) - *) - - and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = - | Pctf_inherit of class_type - (* inherit CT *) - | Pctf_val of (string * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (string * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) - - and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = - { - pci_virt: virtual_flag; - pci_params: (core_type * variance) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... - - Also used for "class type" declaration. - *) - - and class_description = class_type class_infos - - and class_type_declaration = class_type class_infos - - (* Value expressions for the class language *) - - and class_expr (*IF_CURRENT = Parsetree.class_expr *) = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = - | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - - and class_structure (*IF_CURRENT = Parsetree.class_structure *) = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } - (* object(selfpat) ... end - object ... end (self = Ppat_any) - *) - - and class_field (*IF_CURRENT = Parsetree.class_field *) = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_field_desc (*IF_CURRENT = Parsetree.class_field_desc *) = - | Pcf_inherit of override_flag * class_expr * string option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) - | Pcf_val of (string loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) - | Pcf_method of (string loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) - - and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - - and class_declaration = class_expr class_infos - - (** {2 Module language} *) - - (* Type expressions for the module language *) - - and module_type (*IF_CURRENT = Parsetree.module_type *) = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) - | Pmty_functor of string loc * module_type option * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) - - and signature = signature_item list - - and signature_item (*IF_CURRENT = Parsetree.signature_item *) = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - - and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = - | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) - | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of extension_constructor - (* exception C of T *) - | Psig_module of module_declaration - (* module X : MT *) - | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) - | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) - | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) - - and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = - { - pmd_name: string loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } - (* S : MT *) - - and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } - (* S = MT - S (abstract module type declaration, pmtd_type = None) - *) - - and open_description (*IF_CURRENT = Parsetree.open_description *) = - { - popen_lid: Longident.t loc; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } - (* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) - - and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - - and include_description = module_type include_infos - (* include MT *) - - and include_declaration = module_expr include_infos - (* include ME *) - - and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = - | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) - | Pwith_typesubst of type_declaration - (* with type t := ... *) - | Pwith_modsubst of string loc * Longident.t loc - (* with module X := Z *) - - (* Value expressions for the module language *) - - and module_expr (*IF_CURRENT = Parsetree.module_expr *) = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) - | Pmod_functor of string loc * module_type option * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) - - and structure = structure_item list - - and structure_item (*IF_CURRENT = Parsetree.structure_item *) = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - - and structure_item_desc (*IF_CURRENT = Parsetree.structure_item_desc *) = - | Pstr_eval of expression * attributes - (* E *) - | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) - | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) - | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) - | Pstr_exception of extension_constructor - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) - | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_description - (* open X *) - | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) - | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) - - and value_binding (*IF_CURRENT = Parsetree.value_binding *) = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - - and module_binding (*IF_CURRENT = Parsetree.module_binding *) = - { - pmb_name: string loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } - (* X = ME *) - - (** {2 Toplevel} *) - - (* Toplevel phrases *) - - type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = - | Ptop_def of structure - | Ptop_dir of string * directive_argument - (* #use, #load ... *) - - and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = - | Pdir_none - | Pdir_string of string - | Pdir_int of string * char option - | Pdir_ident of Longident.t - | Pdir_bool of bool -end - -module Docstrings : sig - (** {3 Docstrings} *) - - (** Documentation comments *) - type docstring - - (** Create a docstring *) - val docstring : string -> Location.t -> docstring - - (** Get the text of a docstring *) - val docstring_body : docstring -> string - - (** Get the location of a docstring *) - val docstring_loc : docstring -> Location.t - - (** {3 Items} - - The {!docs} type represents documentation attached to an item. *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - val empty_docs : docs - - val docs_attr : docstring -> Parsetree.attribute - - (** Convert item documentation to attributes and add them to an - attribute list *) - val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - - (** {3 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - - type info = docstring option - - val empty_info : info - - val info_attr : docstring -> Parsetree.attribute - - (** Convert field info to attributes and add them to an - attribute list *) - val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - - (** {3 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - - type text = docstring list - - val empty_text : text - - val text_attr : docstring -> Parsetree.attribute - - (** Convert text to attributes and add them to an attribute list *) - val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - -end = struct - open Location - - (* Docstrings *) - - type docstring = - { ds_body: string; - ds_loc: Location.t; } - - (* Docstring constructors and destructors *) - - let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; } - in - ds - - let docstring_body ds = ds.ds_body - - let docstring_loc ds = ds.ds_loc - - (* Docstrings attached to items *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - let empty_docs = { docs_pre = None; docs_post = None } - - let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - - let docs_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (doc_loc, PStr [item]) - - let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - - (* Docstrings attached to constructors or fields *) - - type info = docstring option - - let empty_info = None - - let info_attr = docs_attr - - let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - - (* Docstrings not attached to a specific item *) - - type text = docstring list - - let empty_text = [] - - let text_loc = {txt = "ocaml.text"; loc = Location.none} - - let text_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (text_loc, PStr [item]) - - let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""; _} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - -end - -module Ast_helper : sig - (** Helpers to produce Parsetree fragments *) - - open Asttypes - open Docstrings - open Parsetree - - type lid = Longident.t loc - type str = string loc - type loc = Location.t - type attrs = attribute list - - (** {2 Default locations} *) - - val default_loc: loc ref - (** Default value for all optional location arguments. *) - - val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - - (** {2 Constants} *) - - module Const : sig - val char : char -> constant - val string : ?quotation_delimiter:string -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant - end - - (** {2 Core language} *) - - (** Type expressions *) - module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> - (string * attributes * core_type) list -> closed_flag -> - core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> string list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - end - - (** Patterns *) - module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - - (** Expressions *) - module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> string -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression - -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> string -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression - -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - end - - (** Value declarations *) - module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - - (** Type declarations *) - module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * variance) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - - (** Type extensions *) - module Te: - sig - val mk: ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * variance) list -> ?priv:private_flag -> - lid -> extension_constructor list -> type_extension - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - - (** {2 Module language} *) - - (** Module type expressions *) - module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - - (** Module expressions *) - module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - - (** Signature items *) - module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> extension_constructor -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - - (** Structure items *) - module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> extension_constructor -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_description -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - - (** Module declarations *) - module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_type -> module_declaration - end - - (** Module type declarations *) - module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - - (** Module bindings *) - module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_expr -> module_binding - end - - (** Opens *) - module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> lid -> open_description - end - - (** Includes *) - module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - - (** Value bindings *) - module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - - (** {2 Class language} *) - - (** Class type expressions *) - module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - end - - (** Class type fields *) - module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> string -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> string -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - - (** Class expressions *) - module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - end - - (** Class fields *) - module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - string option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - - (** Classes *) - module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> ?params:(core_type * variance) list -> - str -> 'a -> 'a class_infos - end - - (** Class signatures *) - module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - - (** Class structures *) - module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - -end = struct - (** Helpers to produce Parsetree fragments *) - - open Asttypes - open Parsetree - open Docstrings - - type lid = Longident.t loc - type str = string loc - type loc = Location.t - type attrs = attribute list - - let default_loc = ref Location.none - - let with_default_loc l f = - let old = !default_loc in - default_loc := l; - try let r = f () in default_loc := old; r - with exn -> default_loc := old; raise exn - - module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (string_of_int i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) - end - - module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - end - - module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) - end - - module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - end - - module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) - end - - module Mod = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg arg_ty body = - mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) - end - - module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - end - - module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - end - - module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - - end - - module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - - end - - module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } - end - - module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } - end - - module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } - end - - module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } - end - - module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) lid = - { - popen_lid = lid; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } - end - - module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - - end - - module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } - end - - module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } - end - - module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - - end - - (** Type extensions *) - module Te = struct - let mk ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - end - - module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } - end - - module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } - end - -end - -module Ast_mapper : sig - (** The interface of a -ppx rewriter - - A -ppx rewriter is a program that accepts a serialized abstract syntax - tree and outputs another, possibly modified, abstract syntax tree. - This module encapsulates the interface between the compiler and - the -ppx rewriters, handling such details as the serialization format, - forwarding of command-line flags, and storing state. - - {!mapper} allows to implement AST rewriting using open recursion. - A typical mapper would be based on {!default_mapper}, a deep - identity mapper, and will fall back on it for handling the syntax it - does not modify. For example: - - {[ - open Asttypes - open Parsetree - open Ast_mapper - - let test_mapper argv = - { default_mapper with - expr = fun mapper expr -> - match expr with - | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> - Ast_helper.Exp.constant (Const_int 42) - | other -> default_mapper.expr mapper other; } - - let () = - register "ppx_test" test_mapper]} - - This -ppx rewriter, which replaces [[%test]] in expressions with - the constant [42], can be compiled using - [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. - - *) - - open Parsetree - - (** {2 A generic Parsetree mapper} *) - - type mapper (*IF_CURRENT = Ast_mapper.mapper*) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - (** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - - val default_mapper: mapper - (** A default mapper, which implements a "deep identity" mapping. *) - - (** {2 Convenience functions to write mappers} *) - - val map_opt: ('a -> 'b) -> 'a option -> 'b option - - val extension_of_error: Locations.location_error -> extension - (** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) - - val attribute_of_warning: Location.t -> string -> attribute - (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) - - include Locations.Helpers_intf - -end = struct - (* A generic Parsetree mapping class *) - - (* - [@@@ocaml.warning "+9"] - (* Ensure that record patterns don't miss any field. *) - *) - - - open Parsetree - open Ast_helper - open Location - - type mapper (*IF_CURRENT = Ast_mapper.mapper*) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - - let map_fst f (x, y) = (f x, y) - let map_snd f (x, y) = (x, f y) - let map_tuple f1 f2 (x, y) = (f1 x, f2 y) - let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) - let map_opt f = function None -> None | Some x -> Some (f x) - - let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - - module T = struct - (* Type expressions for the core language *) - - let row_field sub = function - | Rtag (l, attrs, b, tl) -> - Rtag (l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - let f (s, a, t) = (s, sub.attributes sub a, sub.typ sub t) in - object_ ~loc ~attrs (List.map f l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs sl (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - Type.mk (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - ~loc:(sub.location sub ptype_loc) - ~attrs:(sub.attributes sub ptype_attributes) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_attributes} = - Te.mk - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - ~attrs:(sub.attributes sub ptyext_attributes) - - let map_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - Te.constructor - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - ~loc:(sub.location sub pext_loc) - ~attrs:(sub.attributes sub pext_attributes) - - end - - module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) - end - - module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (s, mt1, mt2) -> - functor_ ~loc ~attrs (map_loc sub s) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) mt1) - (sub.module_type sub mt2) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_typesubst d -> Pwith_typesubst (sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) - end - - - module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (arg, arg_ty, body) -> - functor_ ~loc ~attrs (map_loc sub arg) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) arg_ty) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_description sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) - end - - module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs x - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) s - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> newtype ~loc ~attrs s (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (ovf, lid, e) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () - end - - module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs c - | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) - end - - module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub.class_expr sub ce) s - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - Ci.mk - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) - ~loc:(sub.location sub pci_loc) - ~attrs:(sub.attributes sub pci_attributes) - end - - (* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - - let default_mapper = - { - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_description = - (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_lid) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - - let extension_of_error (error : Locations.location_error) : extension = - Locations.extension_of_error - ~mk_pstr:(function - | x :: l -> PStr (x :: x :: l) - | l -> PStr l) - ~mk_extension:(fun x -> Str.extension x) - ~mk_string_constant:(fun x -> Str.eval (Exp.constant (Pconst_string (x, None)))) - error - - let attribute_of_warning loc s = - { loc; txt = "ocaml.ppwarning" }, - PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, None)))]) - - include Locations.Helpers_impl - -end - module Outcometree = struct (* Module [Outcometree]: results displayed by the toplevel *) @@ -2859,110 +194,3 @@ module Outcometree = struct | Ophr_exception of (exn * out_value) end - -module Config = struct - let ast_impl_magic_number = "Caml1999M020" - let ast_intf_magic_number = "Caml1999N018" -end - -let map_signature mapper = mapper.Ast_mapper.signature mapper -let map_structure mapper = mapper.Ast_mapper.structure mapper - -let shallow_identity = - let id _ x = x in - { - Ast_mapper. - structure = id; - structure_item = id; - module_expr = id; - signature = id; - signature_item = id; - module_type = id; - with_constraint = id; - class_declaration = id; - class_expr = id; - class_field = id; - class_structure = id; - class_type = id; - class_type_field = id; - class_signature = id; - class_type_declaration = id; - class_description = id; - type_declaration = id; - type_kind = id; - typ = id; - type_extension = id; - extension_constructor = id; - value_description = id; - pat = id; - expr = id; - module_declaration = id; - module_type_declaration = id; - module_binding = id; - open_description = id; - include_description = id; - include_declaration = id; - value_binding = id; - constructor_declaration = id; - label_declaration = id; - cases = id; - case = id; - location = id; - extension = id; - attribute = id; - attributes = id; - payload = id; - } - -let failing_mapper = - let fail _ _ = - invalid_arg "failing_mapper: this mapper function should never get called" - in - { - Ast_mapper. - structure = fail; - structure_item = fail; - module_expr = fail; - signature = fail; - signature_item = fail; - module_type = fail; - with_constraint = fail; - class_declaration = fail; - class_expr = fail; - class_field = fail; - class_structure = fail; - class_type = fail; - class_type_field = fail; - class_signature = fail; - class_type_declaration = fail; - class_description = fail; - type_declaration = fail; - type_kind = fail; - typ = fail; - type_extension = fail; - extension_constructor = fail; - value_description = fail; - pat = fail; - expr = fail; - module_declaration = fail; - module_type_declaration = fail; - module_binding = fail; - open_description = fail; - include_description = fail; - include_declaration = fail; - value_binding = fail; - constructor_declaration = fail; - label_declaration = fail; - cases = fail; - case = fail; - location = fail; - extension = fail; - attribute = fail; - attributes = fail; - payload = fail; - } - -let make_top_mapper ~signature ~structure = - {failing_mapper with Ast_mapper. - signature = (fun _ x -> signature x); - structure = (fun _ x -> structure x) } diff --git a/src/vendored-omp/src/ast_405.ml b/src/vendored-omp/src/ast_405.ml index de350f163..e69c7faec 100644 --- a/src/vendored-omp/src/ast_405.ml +++ b/src/vendored-omp/src/ast_405.ml @@ -66,2744 +66,6 @@ module Asttypes = struct | Invariant end -module Parsetree = struct - (** Abstract syntax tree produced by parsing *) - - open Asttypes - - type constant (*IF_CURRENT = Parsetree.constant *) = - Pconst_integer of string * char option - (* 3 3l 3L 3n - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker - *) - | Pconst_char of char - (* 'c' *) - | Pconst_string of string * string option - (* "constant" - {delim|other constant|delim} - *) - | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - - (** {2 Extension points} *) - - type attribute = string loc * payload - (* [@id ARG] - [@@id ARG] - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - - and extension = string loc * payload - (* [%id ARG] - [%%id ARG] - - Sub-language placeholder -- rejected by the typechecker. - *) - - and attributes = attribute list - - and payload (*IF_CURRENT = Parsetree.payload *) = - | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - - (** {2 Core language} *) - - (* Type expressions *) - - and core_type (*IF_CURRENT = Parsetree.core_type *) = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Otional - *) - | Ptyp_tuple of core_type list - (* T1 * ... * Tn - - Invariant: n >= 2 - *) - | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of (string loc * attributes * core_type) list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). - - - As the core_type of a Pctf_method node. - - - As the core_type of a Pexp_poly node. - - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) - - and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) - - and row_field (*IF_CURRENT = Parsetree.row_field *) = - | Rtag of label * attributes * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 2nd field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - - - TODO: switch to a record representation, and keep location - *) - | Rinherit of core_type - (* [ T ] *) - - (* Patterns *) - - and pattern (*IF_CURRENT = Parsetree.pattern *) = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Ppat_interval of constant * constant - (* 'a'..'z' - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (* (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Ppat_construct of Longident.t loc * pattern option - (* C None - C P Some P - C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) - *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) - | Ppat_unpack of string loc - (* (module P) - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of Longident.t loc * pattern - (* M.(P) *) - - (* Value expressions *) - - and expression (*IF_CURRENT = Parsetree.expression *) = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = - | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) - | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_tuple of expression list - (* (E1, ..., En) - - Invariant: n >= 2 - *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) - | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) - | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * string loc - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of string loc * expression - (* x <- 2 *) - | Pexp_override of (string loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) - | Pexp_letmodule of string loc * module_expr * expression - (* let module M = ME in E *) - | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) - | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) - | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string loc * expression - (* fun (type t) -> E *) - | Pexp_pack of module_expr - (* (module ME) - - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of override_flag * Longident.t loc * expression - (* M.(E) - let open M in E - let! open M in E *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable - (* . *) - - and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - - (* Value descriptions *) - - and value_description (*IF_CURRENT = Parsetree.value_description *) = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } - - (* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) - *) - - (* Type declarations *) - - and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = - { - ptype_name: string loc; - ptype_params: (core_type * variance) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } - - (* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) - *) - - and type_kind (*IF_CURRENT = Parsetree.type_kind *) = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - (* Invariant: non-empty list *) - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) - | Ptype_open - - and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l [@id1] [@id2] : T *) - } - - (* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. - *) - - and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = - { - pcd_name: string loc; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C [@id1] [@id2] of ... *) - } - - and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - - (* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) - *) - - and type_extension (*IF_CURRENT = Parsetree.type_extension *) = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * variance) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* - type t += ... - *) - - and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C [@id1] [@id2] of ... *) - } - - and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = - Pext_decl of constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([T1; ...; Tn], None) - | C: T0 ([], Some T0) - | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) - *) - | Pext_rebind of Longident.t loc - (* - | C = D - *) - - (** {2 Class language} *) - - (* Type expressions for the class language *) - - and class_type (*IF_CURRENT = Parsetree.class_type *) = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = - | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) - | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - - and class_signature (*IF_CURRENT = Parsetree.class_signature *) = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } - (* object('selfpat) ... end - object ... end (self = Ptyp_any) - *) - - and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = - | Pctf_inherit of class_type - (* inherit CT *) - | Pctf_val of (string loc * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (string loc * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) - - and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = - { - pci_virt: virtual_flag; - pci_params: (core_type * variance) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... - - Also used for "class type" declaration. - *) - - and class_description = class_type class_infos - - and class_type_declaration = class_type class_infos - - (* Value expressions for the class language *) - - and class_expr (*IF_CURRENT = Parsetree.class_expr *) = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = - | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - - and class_structure (*IF_CURRENT = Parsetree.class_structure *) = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } - (* object(selfpat) ... end - object ... end (self = Ppat_any) - *) - - and class_field (*IF_CURRENT = Parsetree.class_field *) = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_field_desc (*IF_CURRENT = Parsetree.class_field_desc *) = - | Pcf_inherit of override_flag * class_expr * string loc option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) - | Pcf_val of (string loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) - | Pcf_method of (string loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) - - and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - - and class_declaration = class_expr class_infos - - (** {2 Module language} *) - - (* Type expressions for the module language *) - - and module_type (*IF_CURRENT = Parsetree.module_type *) = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) - | Pmty_functor of string loc * module_type option * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) - - and signature = signature_item list - - and signature_item (*IF_CURRENT = Parsetree.signature_item *) = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - - and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = - | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) - | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of extension_constructor - (* exception C of T *) - | Psig_module of module_declaration - (* module X : MT *) - | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) - | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) - | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) - - and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = - { - pmd_name: string loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } - (* S : MT *) - - and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } - (* S = MT - S (abstract module type declaration, pmtd_type = None) - *) - - and open_description (*IF_CURRENT = Parsetree.open_description *) = - { - popen_lid: Longident.t loc; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } - (* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) - - and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - - and include_description = module_type include_infos - (* include MT *) - - and include_declaration = module_expr include_infos - (* include ME *) - - and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = - | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) - | Pwith_typesubst of type_declaration - (* with type t := ... *) - | Pwith_modsubst of string loc * Longident.t loc - (* with module X := Z *) - - (* Value expressions for the module language *) - - and module_expr (*IF_CURRENT = Parsetree.module_expr *) = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) - | Pmod_functor of string loc * module_type option * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) - - and structure = structure_item list - - and structure_item (*IF_CURRENT = Parsetree.structure_item *) = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - - and structure_item_desc (*IF_CURRENT = Parsetree.structure_item_desc *) = - | Pstr_eval of expression * attributes - (* E *) - | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) - | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) - | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) - | Pstr_exception of extension_constructor - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) - | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_description - (* open X *) - | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) - | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) - - and value_binding (*IF_CURRENT = Parsetree.value_binding *) = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - - and module_binding (*IF_CURRENT = Parsetree.module_binding *) = - { - pmb_name: string loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } - (* X = ME *) - - (** {2 Toplevel} *) - - (* Toplevel phrases *) - - type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = - | Ptop_def of structure - | Ptop_dir of string * directive_argument - (* #use, #load ... *) - - and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = - | Pdir_none - | Pdir_string of string - | Pdir_int of string * char option - | Pdir_ident of Longident.t - | Pdir_bool of bool - -end - -module Docstrings : sig - (** {3 Docstrings} *) - - (** Documentation comments *) - type docstring - - (** Create a docstring *) - val docstring : string -> Location.t -> docstring - - (** Get the text of a docstring *) - val docstring_body : docstring -> string - - (** Get the location of a docstring *) - val docstring_loc : docstring -> Location.t - - (** {3 Items} - - The {!docs} type represents documentation attached to an item. *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - val empty_docs : docs - - val docs_attr : docstring -> Parsetree.attribute - - (** Convert item documentation to attributes and add them to an - attribute list *) - val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - - (** {3 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - - type info = docstring option - - val empty_info : info - - val info_attr : docstring -> Parsetree.attribute - - (** Convert field info to attributes and add them to an - attribute list *) - val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - - (** {3 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - - type text = docstring list - - val empty_text : text - - val text_attr : docstring -> Parsetree.attribute - - (** Convert text to attributes and add them to an attribute list *) - val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - -end = struct - open Location - - (* Docstrings *) - - type docstring = - { ds_body: string; - ds_loc: Location.t; - } - - (* Docstring constructors and destructors *) - - let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; - } - in - ds - - let docstring_body ds = ds.ds_body - - let docstring_loc ds = ds.ds_loc - - (* Docstrings attached to items *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - let empty_docs = { docs_pre = None; docs_post = None } - - let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - - let docs_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (doc_loc, PStr [item]) - - let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - - (* Docstrings attached to constructors or fields *) - - type info = docstring option - - let empty_info = None - - let info_attr = docs_attr - - let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - - (* Docstrings not attached to a specific item *) - - type text = docstring list - - let empty_text = [] - - let text_loc = {txt = "ocaml.text"; loc = Location.none} - - let text_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (text_loc, PStr [item]) - - let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""; _} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - -end - -module Ast_helper : sig - - (** Helpers to produce Parsetree fragments *) - - open Asttypes - open Docstrings - open Parsetree - - type lid = Longident.t loc - type str = string loc - type loc = Location.t - type attrs = attribute list - - (** {2 Default locations} *) - - val default_loc: loc ref - (** Default value for all optional location arguments. *) - - val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - - (** {2 Constants} *) - - module Const : sig - val char : char -> constant - val string : ?quotation_delimiter:string -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant - end - - (** {2 Core language} *) - - (** Type expressions *) - module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> - (str * attributes * core_type) list -> closed_flag -> - core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - - (** Patterns *) - module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - - (** Expressions *) - module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression - -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression - -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - end - - (** Value declarations *) - module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - - (** Type declarations *) - module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * variance) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - - (** Type extensions *) - module Te: - sig - val mk: ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * variance) list -> ?priv:private_flag -> - lid -> extension_constructor list -> type_extension - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - - (** {2 Module language} *) - - (** Module type expressions *) - module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - - (** Module expressions *) - module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - - (** Signature items *) - module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> extension_constructor -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - - (** Structure items *) - module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> extension_constructor -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_description -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - - (** Module declarations *) - module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_type -> module_declaration - end - - (** Module type declarations *) - module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - - (** Module bindings *) - module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_expr -> module_binding - end - - (** Opens *) - module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> lid -> open_description - end - - (** Includes *) - module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - - (** Value bindings *) - module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - - (** {2 Class language} *) - - (** Class type expressions *) - module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - end - - (** Class type fields *) - module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - - (** Class expressions *) - module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - end - - (** Class fields *) - module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - - (** Classes *) - module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> ?params:(core_type * variance) list -> - str -> 'a -> 'a class_infos - end - - (** Class signatures *) - module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - - (** Class structures *) - module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - -end = struct - (** Helpers to produce Parsetree fragments *) - - open Asttypes - open Parsetree - open Docstrings - - type lid = Longident.t loc - type str = string loc - type loc = Location.t - type attrs = attribute list - - let default_loc = ref Location.none - - let with_default_loc l f = - let old = !default_loc in - default_loc := l; - try let r = f () in default_loc := old; r - with exn -> default_loc := old; raise exn - - module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (string_of_int i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) - end - - module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - - let varify_constructors var_names t = - let check_variable vl loc v = - if List.mem v vl then - raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in - let var_names = List.map (fun v -> v.txt) var_names in - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> - check_variable var_names t.ptyp_loc x; - Ptyp_var x - | Ptyp_arrow (label,core_type,core_type') -> - Ptyp_arrow(label, loop core_type, loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr( { txt = Longident.Lident s; _ }, []) - when List.mem s var_names -> - Ptyp_var s - | Ptyp_constr(longident, lst) -> - Ptyp_constr(longident, List.map loop lst) - | Ptyp_object (lst, o) -> - Ptyp_object - (List.map (fun (s, attrs, t) -> (s, attrs, loop t)) lst, o) - | Ptyp_class (longident, lst) -> - Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) - in - {t with ptyp_desc = desc} - and loop_row_field = - function - | Rtag(label,attrs,flag,lst) -> - Rtag(label,attrs,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - in - loop t - - end - - module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) - end - - module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - end - - module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) - end - - module Mod = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg arg_ty body = - mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) - end - - module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - end - - module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - end - - module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - - end - - module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - - end - - module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } - end - - module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } - end - - module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } - end - - module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } - end - - module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) lid = - { - popen_lid = lid; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } - end - - module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - - end - - module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } - end - - module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } - end - - module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - - end - - (** Type extensions *) - module Te = struct - let mk ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - end - - module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } - end - - module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } - end - -end - -module Ast_mapper : sig - (** The interface of a -ppx rewriter - - A -ppx rewriter is a program that accepts a serialized abstract syntax - tree and outputs another, possibly modified, abstract syntax tree. - This module encapsulates the interface between the compiler and - the -ppx rewriters, handling such details as the serialization format, - forwarding of command-line flags, and storing state. - - {!mapper} allows to implement AST rewriting using open recursion. - A typical mapper would be based on {!default_mapper}, a deep - identity mapper, and will fall back on it for handling the syntax it - does not modify. For example: - - {[ - open Asttypes - open Parsetree - open Ast_mapper - - let test_mapper argv = - { default_mapper with - expr = fun mapper expr -> - match expr with - | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> - Ast_helper.Exp.constant (Const_int 42) - | other -> default_mapper.expr mapper other; } - - let () = - register "ppx_test" test_mapper]} - - This -ppx rewriter, which replaces [[%test]] in expressions with - the constant [42], can be compiled using - [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. - - *) - - open Parsetree - - (** {2 A generic Parsetree mapper} *) - - type mapper (*IF_CURRENT = Ast_mapper.mapper*) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - (** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - - val default_mapper: mapper - (** A default mapper, which implements a "deep identity" mapping. *) - - (** {2 Convenience functions to write mappers} *) - - val map_opt: ('a -> 'b) -> 'a option -> 'b option - - val extension_of_error: Locations.location_error -> extension - (** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) - - val attribute_of_warning: Location.t -> string -> attribute - (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) - - include Locations.Helpers_intf - -end = struct - (* A generic Parsetree mapping class *) - - (* - [@@@ocaml.warning "+9"] - (* Ensure that record patterns don't miss any field. *) - *) - - - open Parsetree - open Ast_helper - open Location - - type mapper (*IF_CURRENT = Ast_mapper.mapper*) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - - let map_fst f (x, y) = (f x, y) - let map_snd f (x, y) = (x, f y) - let map_tuple f1 f2 (x, y) = (f1 x, f2 y) - let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) - let map_opt f = function None -> None | Some x -> Some (f x) - - let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - - module T = struct - (* Type expressions for the core language *) - - let row_field sub = function - | Rtag (l, attrs, b, tl) -> - Rtag (l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - let f (s, a, t) = - (map_loc sub s, sub.attributes sub a, sub.typ sub t) in - object_ ~loc ~attrs (List.map f l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs - (List.map (map_loc sub) sl) (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - Type.mk (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - ~loc:(sub.location sub ptype_loc) - ~attrs:(sub.attributes sub ptype_attributes) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_attributes} = - Te.mk - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - ~attrs:(sub.attributes sub ptyext_attributes) - - let map_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - Te.constructor - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - ~loc:(sub.location sub pext_loc) - ~attrs:(sub.attributes sub pext_attributes) - - end - - module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) - end - - module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (s, mt1, mt2) -> - functor_ ~loc ~attrs (map_loc sub s) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) mt1) - (sub.module_type sub mt2) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_typesubst d -> Pwith_typesubst (sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) - end - - - module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (arg, arg_ty, body) -> - functor_ ~loc ~attrs (map_loc sub arg) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) arg_ty) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_description sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) - end - - module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs x - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> - send ~loc ~attrs (sub.expr sub e) (map_loc sub s) - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (ovf, lid, e) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () - end - - module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs c - | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) - end - - module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> - inherit_ ~loc ~attrs o (sub.class_expr sub ce) - (map_opt (map_loc sub) s) - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - Ci.mk - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) - ~loc:(sub.location sub pci_loc) - ~attrs:(sub.attributes sub pci_attributes) - end - - (* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - - let default_mapper = - { - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_description = - (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_lid) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - - let extension_of_error (error : Locations.location_error) : extension = - Locations.extension_of_error - ~mk_pstr:(function - | x :: l -> PStr (x :: x :: l) - | l -> PStr l) - ~mk_extension:(fun x -> Str.extension x) - ~mk_string_constant:(fun x -> Str.eval (Exp.constant (Pconst_string (x, None)))) - error - - let attribute_of_warning loc s = - { loc; txt = "ocaml.ppwarning" }, - PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, None)))]) - - include Locations.Helpers_impl - -end - module Outcometree = struct (* Module [Outcometree]: results displayed by the toplevel *) @@ -2933,109 +195,3 @@ module Outcometree = struct end -module Config = struct - let ast_impl_magic_number = "Caml1999M020" - let ast_intf_magic_number = "Caml1999N018" -end - -let map_signature mapper = mapper.Ast_mapper.signature mapper -let map_structure mapper = mapper.Ast_mapper.structure mapper - -let shallow_identity = - let id _ x = x in - { - Ast_mapper. - structure = id; - structure_item = id; - module_expr = id; - signature = id; - signature_item = id; - module_type = id; - with_constraint = id; - class_declaration = id; - class_expr = id; - class_field = id; - class_structure = id; - class_type = id; - class_type_field = id; - class_signature = id; - class_type_declaration = id; - class_description = id; - type_declaration = id; - type_kind = id; - typ = id; - type_extension = id; - extension_constructor = id; - value_description = id; - pat = id; - expr = id; - module_declaration = id; - module_type_declaration = id; - module_binding = id; - open_description = id; - include_description = id; - include_declaration = id; - value_binding = id; - constructor_declaration = id; - label_declaration = id; - cases = id; - case = id; - location = id; - extension = id; - attribute = id; - attributes = id; - payload = id; - } - -let failing_mapper = - let fail _ _ = - invalid_arg "failing_mapper: this mapper function should never get called" - in - { - Ast_mapper. - structure = fail; - structure_item = fail; - module_expr = fail; - signature = fail; - signature_item = fail; - module_type = fail; - with_constraint = fail; - class_declaration = fail; - class_expr = fail; - class_field = fail; - class_structure = fail; - class_type = fail; - class_type_field = fail; - class_signature = fail; - class_type_declaration = fail; - class_description = fail; - type_declaration = fail; - type_kind = fail; - typ = fail; - type_extension = fail; - extension_constructor = fail; - value_description = fail; - pat = fail; - expr = fail; - module_declaration = fail; - module_type_declaration = fail; - module_binding = fail; - open_description = fail; - include_description = fail; - include_declaration = fail; - value_binding = fail; - constructor_declaration = fail; - label_declaration = fail; - cases = fail; - case = fail; - location = fail; - extension = fail; - attribute = fail; - attributes = fail; - payload = fail; - } - -let make_top_mapper ~signature ~structure = - {failing_mapper with Ast_mapper. - signature = (fun _ x -> signature x); - structure = (fun _ x -> structure x) } diff --git a/src/vendored-omp/src/ast_406.ml b/src/vendored-omp/src/ast_406.ml index 245808474..c95805f92 100644 --- a/src/vendored-omp/src/ast_406.ml +++ b/src/vendored-omp/src/ast_406.ml @@ -75,2773 +75,6 @@ module Asttypes = struct | Invariant end -module Parsetree = struct - (** Abstract syntax tree produced by parsing *) - - open Asttypes - - type constant (*IF_CURRENT = Parsetree.constant *) = - Pconst_integer of string * char option - (* 3 3l 3L 3n - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker - *) - | Pconst_char of char - (* 'c' *) - | Pconst_string of string * string option - (* "constant" - {delim|other constant|delim} - *) - | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - - (** {2 Extension points} *) - - type attribute = string loc * payload - (* [@id ARG] - [@@id ARG] - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - - and extension = string loc * payload - (* [%id ARG] - [%%id ARG] - - Sub-language placeholder -- rejected by the typechecker. - *) - - and attributes = attribute list - - and payload (*IF_CURRENT = Parsetree.payload *) = - | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - - (** {2 Core language} *) - - (* Type expressions *) - - and core_type (*IF_CURRENT = Parsetree.core_type *) = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional - *) - | Ptyp_tuple of core_type list - (* T1 * ... * Tn - - Invariant: n >= 2 - *) - | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of object_field list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). - - - As the core_type of a Pctf_method node. - - - As the core_type of a Pexp_poly node. - - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) - - and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) - - and row_field (*IF_CURRENT = Parsetree.row_field *) = - | Rtag of label loc * attributes * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 2nd field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - - - TODO: switch to a record representation, and keep location - *) - | Rinherit of core_type - (* [ T ] *) - - and object_field (*IF_CURRENT = Parsetree.object_field *) = - | Otag of label loc * attributes * core_type - | Oinherit of core_type - - (* Patterns *) - - and pattern (*IF_CURRENT = Parsetree.pattern *) = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Ppat_interval of constant * constant - (* 'a'..'z' - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (* (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Ppat_construct of Longident.t loc * pattern option - (* C None - C P Some P - C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) - *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) - | Ppat_unpack of string loc - (* (module P) - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of Longident.t loc * pattern - (* M.(P) *) - - (* Value expressions *) - - and expression (*IF_CURRENT = Parsetree.expression *) = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = - | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) - | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_tuple of expression list - (* (E1, ..., En) - - Invariant: n >= 2 - *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) - | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) - | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * label loc - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of label loc * expression - (* x <- 2 *) - | Pexp_override of (label loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) - | Pexp_letmodule of string loc * module_expr * expression - (* let module M = ME in E *) - | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) - | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) - | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string loc * expression - (* fun (type t) -> E *) - | Pexp_pack of module_expr - (* (module ME) - - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of override_flag * Longident.t loc * expression - (* M.(E) - let open M in E - let! open M in E *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable - (* . *) - - and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - - (* Value descriptions *) - - and value_description (*IF_CURRENT = Parsetree.value_description *) = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } - - (* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) - *) - - (* Type declarations *) - - and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = - { - ptype_name: string loc; - ptype_params: (core_type * variance) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } - - (* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) - *) - - and type_kind (*IF_CURRENT = Parsetree.type_kind *) = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - (* Invariant: non-empty list *) - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) - | Ptype_open - - and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l : T [@id1] [@id2] *) - } - - (* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. - *) - - and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = - { - pcd_name: string loc; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - - (* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) - *) - - and type_extension (*IF_CURRENT = Parsetree.type_extension *) = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * variance) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* - type t += ... - *) - - and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = - Pext_decl of constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([T1; ...; Tn], None) - | C: T0 ([], Some T0) - | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) - *) - | Pext_rebind of Longident.t loc - (* - | C = D - *) - - (** {2 Class language} *) - - (* Type expressions for the class language *) - - and class_type (*IF_CURRENT = Parsetree.class_type *) = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = - | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) - | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - | Pcty_open of override_flag * Longident.t loc * class_type - (* let open M in CT *) - - - and class_signature (*IF_CURRENT = Parsetree.class_signature *) = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } - (* object('selfpat) ... end - object ... end (self = Ptyp_any) - *) - - and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = - | Pctf_inherit of class_type - (* inherit CT *) - | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) - - and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = - { - pci_virt: virtual_flag; - pci_params: (core_type * variance) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... - - Also used for "class type" declaration. - *) - - and class_description = class_type class_infos - - and class_type_declaration = class_type class_infos - - (* Value expressions for the class language *) - - and class_expr (*IF_CURRENT = Parsetree.class_expr *) = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = - | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - | Pcl_open of override_flag * Longident.t loc * class_expr - (* let open M in CE *) - - - and class_structure (*IF_CURRENT = Parsetree.class_structure *) = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } - (* object(selfpat) ... end - object ... end (self = Ppat_any) - *) - - and class_field (*IF_CURRENT = Parsetree.class_field *) = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_field_desc (*IF_CURRENT = Parsetree.class_field_desc *) = - | Pcf_inherit of override_flag * class_expr * string loc option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) - | Pcf_val of (label loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) - | Pcf_method of (label loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) - - and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - - and class_declaration = class_expr class_infos - - (** {2 Module language} *) - - (* Type expressions for the module language *) - - and module_type (*IF_CURRENT = Parsetree.module_type *) = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) - | Pmty_functor of string loc * module_type option * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) - - and signature = signature_item list - - and signature_item (*IF_CURRENT = Parsetree.signature_item *) = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - - and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = - | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) - | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of extension_constructor - (* exception C of T *) - | Psig_module of module_declaration - (* module X : MT *) - | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) - | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) - | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) - - and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = - { - pmd_name: string loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } - (* S : MT *) - - and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } - (* S = MT - S (abstract module type declaration, pmtd_type = None) - *) - - and open_description (*IF_CURRENT = Parsetree.open_description *) = - { - popen_lid: Longident.t loc; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } - (* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) - - and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - - and include_description = module_type include_infos - (* include MT *) - - and include_declaration = module_expr include_infos - (* include ME *) - - and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = - | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) - | Pwith_typesubst of Longident.t loc * type_declaration - (* with type X.t := ..., same format as [Pwith_type] *) - | Pwith_modsubst of Longident.t loc * Longident.t loc - (* with module X.Y := Z *) - - (* Value expressions for the module language *) - - and module_expr (*IF_CURRENT = Parsetree.module_expr *) = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) - | Pmod_functor of string loc * module_type option * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) - - and structure = structure_item list - - and structure_item (*IF_CURRENT = Parsetree.structure_item *) = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - - and structure_item_desc (*IF_CURRENT = Parsetree.structure_item_desc *) = - | Pstr_eval of expression * attributes - (* E *) - | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) - | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) - | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) - | Pstr_exception of extension_constructor - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) - | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_description - (* open X *) - | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) - | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) - - and value_binding (*IF_CURRENT = Parsetree.value_binding *) = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - - and module_binding (*IF_CURRENT = Parsetree.module_binding *) = - { - pmb_name: string loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } - (* X = ME *) - - (** {2 Toplevel} *) - - (* Toplevel phrases *) - - type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = - | Ptop_def of structure - | Ptop_dir of string * directive_argument - (* #use, #load ... *) - - and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = - | Pdir_none - | Pdir_string of string - | Pdir_int of string * char option - | Pdir_ident of Longident.t - | Pdir_bool of bool - -end - -module Docstrings : sig - (** {3 Docstrings} *) - - (** Documentation comments *) - type docstring - - (** Create a docstring *) - val docstring : string -> Location.t -> docstring - - (** Get the text of a docstring *) - val docstring_body : docstring -> string - - (** Get the location of a docstring *) - val docstring_loc : docstring -> Location.t - - (** {3 Items} - - The {!docs} type represents documentation attached to an item. *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - val empty_docs : docs - - val docs_attr : docstring -> Parsetree.attribute - - (** Convert item documentation to attributes and add them to an - attribute list *) - val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - - (** {3 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - - type info = docstring option - - val empty_info : info - - val info_attr : docstring -> Parsetree.attribute - - (** Convert field info to attributes and add them to an - attribute list *) - val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - - (** {3 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - - type text = docstring list - - val empty_text : text - - val text_attr : docstring -> Parsetree.attribute - - (** Convert text to attributes and add them to an attribute list *) - val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - -end = struct - open Location - - (* Docstrings *) - - type docstring = - { ds_body: string; - ds_loc: Location.t; - } - - (* Docstring constructors and destructors *) - - let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; - } - in - ds - - let docstring_body ds = ds.ds_body - - let docstring_loc ds = ds.ds_loc - - (* Docstrings attached to items *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - let empty_docs = { docs_pre = None; docs_post = None } - - let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - - let docs_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (doc_loc, PStr [item]) - - let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - - (* Docstrings attached to constructors or fields *) - - type info = docstring option - - let empty_info = None - - let info_attr = docs_attr - - let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - - (* Docstrings not attached to a specific item *) - - type text = docstring list - - let empty_text = [] - - let text_loc = {txt = "ocaml.text"; loc = Location.none} - - let text_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (text_loc, PStr [item]) - - let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""; _} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - -end - -module Ast_helper : sig - - (** Helpers to produce Parsetree fragments *) - - open Asttypes - open Docstrings - open Parsetree - - type lid = Longident.t loc - type str = string loc - type loc = Location.t - type attrs = attribute list - - (** {2 Default locations} *) - - val default_loc: loc ref - (** Default value for all optional location arguments. *) - - val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - - (** {2 Constants} *) - - module Const : sig - val char : char -> constant - val string : ?quotation_delimiter:string -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant - end - - (** {2 Core language} *) - - (** Type expressions *) - module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - - (** Patterns *) - module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - - (** Expressions *) - module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression - -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression - -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - end - - (** Value declarations *) - module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - - (** Type declarations *) - module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * variance) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - - (** Type extensions *) - module Te: - sig - val mk: ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * variance) list -> ?priv:private_flag -> - lid -> extension_constructor list -> type_extension - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - - (** {2 Module language} *) - - (** Module type expressions *) - module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - - (** Module expressions *) - module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - - (** Signature items *) - module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> extension_constructor -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - - (** Structure items *) - module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> extension_constructor -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_description -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - - (** Module declarations *) - module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_type -> module_declaration - end - - (** Module type declarations *) - module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - - (** Module bindings *) - module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_expr -> module_binding - end - - (** Opens *) - module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> lid -> open_description - end - - (** Includes *) - module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - - (** Value bindings *) - module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - - (** {2 Class language} *) - - (** Class type expressions *) - module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_type - -> class_type - end - - (** Class type fields *) - module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - - (** Class expressions *) - module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_expr - -> class_expr - end - - (** Class fields *) - module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - - (** Classes *) - module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> ?params:(core_type * variance) list -> - str -> 'a -> 'a class_infos - end - - (** Class signatures *) - module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - - (** Class structures *) - module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - -end = struct - (** Helpers to produce Parsetree fragments *) - - open Asttypes - open Parsetree - open Docstrings - - type lid = Longident.t loc - type str = string loc - type loc = Location.t - type attrs = attribute list - - let default_loc = ref Location.none - - let with_default_loc l f = - let old = !default_loc in - default_loc := l; - try let r = f () in default_loc := old; r - with exn -> default_loc := old; raise exn - - module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (string_of_int i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) - end - - module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - - let varify_constructors var_names t = - let check_variable vl loc v = - if List.mem v vl then - raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in - let var_names = List.map (fun v -> v.txt) var_names in - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> - check_variable var_names t.ptyp_loc x; - Ptyp_var x - | Ptyp_arrow (label,core_type,core_type') -> - Ptyp_arrow(label, loop core_type, loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr( { txt = Longident.Lident s; _ }, []) - when List.mem s var_names -> - Ptyp_var s - | Ptyp_constr(longident, lst) -> - Ptyp_constr(longident, List.map loop lst) - | Ptyp_object (lst, o) -> - Ptyp_object (List.map loop_object_field lst, o) - | Ptyp_class (longident, lst) -> - Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) - in - {t with ptyp_desc = desc} - and loop_row_field = - function - | Rtag(label,attrs,flag,lst) -> - Rtag(label,attrs,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - and loop_object_field = - function - | Otag(label, attrs, t) -> - Otag(label, attrs, loop t) - | Oinherit t -> - Oinherit (loop t) - in - loop t - - end - - module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) - end - - module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - end - - module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) - end - - module Mod = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg arg_ty body = - mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) - end - - module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_open (a, b, c)) - end - - module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_open (a, b, c)) - end - - module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - - end - - module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - - end - - module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } - end - - module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } - end - - module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } - end - - module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } - end - - module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) lid = - { - popen_lid = lid; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } - end - - module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - - end - - module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } - end - - module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } - end - - module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - - end - - (** Type extensions *) - module Te = struct - let mk ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - end - - module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } - end - - module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } - end - -end - -module Ast_mapper : sig - (** The interface of a -ppx rewriter - - A -ppx rewriter is a program that accepts a serialized abstract syntax - tree and outputs another, possibly modified, abstract syntax tree. - This module encapsulates the interface between the compiler and - the -ppx rewriters, handling such details as the serialization format, - forwarding of command-line flags, and storing state. - - {!mapper} allows to implement AST rewriting using open recursion. - A typical mapper would be based on {!default_mapper}, a deep - identity mapper, and will fall back on it for handling the syntax it - does not modify. For example: - - {[ - open Asttypes - open Parsetree - open Ast_mapper - - let test_mapper argv = - { default_mapper with - expr = fun mapper expr -> - match expr with - | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> - Ast_helper.Exp.constant (Const_int 42) - | other -> default_mapper.expr mapper other; } - - let () = - register "ppx_test" test_mapper]} - - This -ppx rewriter, which replaces [[%test]] in expressions with - the constant [42], can be compiled using - [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. - - *) - - open Parsetree - - (** {2 A generic Parsetree mapper} *) - - type mapper (*IF_CURRENT = Ast_mapper.mapper*) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - (** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - - val default_mapper: mapper - (** A default mapper, which implements a "deep identity" mapping. *) - - (** {2 Convenience functions to write mappers} *) - - val map_opt: ('a -> 'b) -> 'a option -> 'b option - - val extension_of_error: Locations.location_error -> extension - (** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) - - val attribute_of_warning: Location.t -> string -> attribute - (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) - - include Locations.Helpers_intf - -end = struct - (* A generic Parsetree mapping class *) - - (* - [@@@ocaml.warning "+9"] - (* Ensure that record patterns don't miss any field. *) - *) - - - open Parsetree - open Ast_helper - open Location - - type mapper (*IF_CURRENT = Ast_mapper.mapper*) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - - let map_fst f (x, y) = (f x, y) - let map_snd f (x, y) = (x, f y) - let map_tuple f1 f2 (x, y) = (f1 x, f2 y) - let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) - let map_opt f = function None -> None | Some x -> Some (f x) - - let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - - module T = struct - (* Type expressions for the core language *) - - let row_field sub = function - | Rtag (l, attrs, b, tl) -> - Rtag (map_loc sub l, sub.attributes sub attrs, - b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - - let object_field sub = function - | Otag (l, attrs, t) -> - Otag (map_loc sub l, sub.attributes sub attrs, sub.typ sub t) - | Oinherit t -> Oinherit (sub.typ sub t) - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs - (List.map (map_loc sub) sl) (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - Type.mk (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - ~loc:(sub.location sub ptype_loc) - ~attrs:(sub.attributes sub ptype_attributes) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_attributes} = - Te.mk - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - ~attrs:(sub.attributes sub ptyext_attributes) - - let map_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - Te.constructor - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - ~loc:(sub.location sub pext_loc) - ~attrs:(sub.attributes sub pext_attributes) - - end - - module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (ovf, lid, ct) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_type sub ct) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) - end - - module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (s, mt1, mt2) -> - functor_ ~loc ~attrs (map_loc sub s) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) mt1) - (sub.module_type sub mt2) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) - end - - - module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (arg, arg_ty, body) -> - functor_ ~loc ~attrs (map_loc sub arg) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) arg_ty) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_description sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) - end - - module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs x - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> - send ~loc ~attrs (sub.expr sub e) (map_loc sub s) - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (ovf, lid, e) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () - end - - module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs c - | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) - end - - module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (ovf, lid, ce) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_expr sub ce) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> - inherit_ ~loc ~attrs o (sub.class_expr sub ce) - (map_opt (map_loc sub) s) - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - Ci.mk - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) - ~loc:(sub.location sub pci_loc) - ~attrs:(sub.attributes sub pci_attributes) - end - - (* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - - let default_mapper = - { - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_description = - (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_lid) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - - let extension_of_error (error : Locations.location_error) : extension = - Locations.extension_of_error - ~mk_pstr:(function - | x :: l -> PStr (x :: x :: l) - | l -> PStr l) - ~mk_extension:(fun x -> Str.extension x) - ~mk_string_constant:(fun x -> Str.eval (Exp.constant (Pconst_string (x, None)))) - error - - let attribute_of_warning loc s = - { loc; txt = "ocaml.ppwarning" }, - PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, None)))]) - - include Locations.Helpers_impl - -end - module Outcometree = struct (* Module [Outcometree]: results displayed by the toplevel *) @@ -2974,110 +207,3 @@ module Outcometree = struct | Ophr_exception of (exn * out_value) end - -module Config = struct - let ast_impl_magic_number = "Caml1999M022" - let ast_intf_magic_number = "Caml1999N022" -end - -let map_signature mapper = mapper.Ast_mapper.signature mapper -let map_structure mapper = mapper.Ast_mapper.structure mapper - -let shallow_identity = - let id _ x = x in - { - Ast_mapper. - structure = id; - structure_item = id; - module_expr = id; - signature = id; - signature_item = id; - module_type = id; - with_constraint = id; - class_declaration = id; - class_expr = id; - class_field = id; - class_structure = id; - class_type = id; - class_type_field = id; - class_signature = id; - class_type_declaration = id; - class_description = id; - type_declaration = id; - type_kind = id; - typ = id; - type_extension = id; - extension_constructor = id; - value_description = id; - pat = id; - expr = id; - module_declaration = id; - module_type_declaration = id; - module_binding = id; - open_description = id; - include_description = id; - include_declaration = id; - value_binding = id; - constructor_declaration = id; - label_declaration = id; - cases = id; - case = id; - location = id; - extension = id; - attribute = id; - attributes = id; - payload = id; - } - -let failing_mapper = - let fail _ _ = - invalid_arg "failing_mapper: this mapper function should never get called" - in - { - Ast_mapper. - structure = fail; - structure_item = fail; - module_expr = fail; - signature = fail; - signature_item = fail; - module_type = fail; - with_constraint = fail; - class_declaration = fail; - class_expr = fail; - class_field = fail; - class_structure = fail; - class_type = fail; - class_type_field = fail; - class_signature = fail; - class_type_declaration = fail; - class_description = fail; - type_declaration = fail; - type_kind = fail; - typ = fail; - type_extension = fail; - extension_constructor = fail; - value_description = fail; - pat = fail; - expr = fail; - module_declaration = fail; - module_type_declaration = fail; - module_binding = fail; - open_description = fail; - include_description = fail; - include_declaration = fail; - value_binding = fail; - constructor_declaration = fail; - label_declaration = fail; - cases = fail; - case = fail; - location = fail; - extension = fail; - attribute = fail; - attributes = fail; - payload = fail; - } - -let make_top_mapper ~signature ~structure = - {failing_mapper with Ast_mapper. - signature = (fun _ x -> signature x); - structure = (fun _ x -> structure x) } diff --git a/src/vendored-omp/src/ast_407.ml b/src/vendored-omp/src/ast_407.ml index d906f7acc..56be09531 100644 --- a/src/vendored-omp/src/ast_407.ml +++ b/src/vendored-omp/src/ast_407.ml @@ -76,2788 +76,6 @@ module Asttypes = struct | Invariant end -module Parsetree = struct - (** Abstract syntax tree produced by parsing *) - - open Asttypes - - type constant (*IF_CURRENT = Parsetree.constant *) = - Pconst_integer of string * char option - (* 3 3l 3L 3n - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker - *) - | Pconst_char of char - (* 'c' *) - | Pconst_string of string * string option - (* "constant" - {delim|other constant|delim} - *) - | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - - (** {1 Extension points} *) - - type attribute = string loc * payload - (* [@id ARG] - [@@id ARG] - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - - and extension = string loc * payload - (* [%id ARG] - [%%id ARG] - - Sub-language placeholder -- rejected by the typechecker. - *) - - and attributes = attribute list - - and payload (*IF_CURRENT = Parsetree.payload *) = - | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - - (** {1 Core language} *) - - (* Type expressions *) - - and core_type (*IF_CURRENT = Parsetree.core_type *) = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional - *) - | Ptyp_tuple of core_type list - (* T1 * ... * Tn - - Invariant: n >= 2 - *) - | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of object_field list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). - - - As the core_type of a Pctf_method node. - - - As the core_type of a Pexp_poly node. - - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) - - and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) - - and row_field (*IF_CURRENT = Parsetree.row_field *) = - | Rtag of label loc * attributes * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 2nd field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - - - TODO: switch to a record representation, and keep location - *) - | Rinherit of core_type - (* [ T ] *) - - and object_field (*IF_CURRENT = Parsetree.object_field *) = - | Otag of label loc * attributes * core_type - | Oinherit of core_type - - (* Patterns *) - - and pattern (*IF_CURRENT = Parsetree.pattern *) = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Ppat_interval of constant * constant - (* 'a'..'z' - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (* (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Ppat_construct of Longident.t loc * pattern option - (* C None - C P Some P - C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) - *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) - | Ppat_unpack of string loc - (* (module P) - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of Longident.t loc * pattern - (* M.(P) *) - - (* Value expressions *) - - and expression (*IF_CURRENT = Parsetree.expression *) = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = - | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) - | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_tuple of expression list - (* (E1, ..., En) - - Invariant: n >= 2 - *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) - | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) - | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * label loc - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of label loc * expression - (* x <- 2 *) - | Pexp_override of (label loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) - | Pexp_letmodule of string loc * module_expr * expression - (* let module M = ME in E *) - | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) - | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) - | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string loc * expression - (* fun (type t) -> E *) - | Pexp_pack of module_expr - (* (module ME) - - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of override_flag * Longident.t loc * expression - (* M.(E) - let open M in E - let! open M in E *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable - (* . *) - - and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - - (* Value descriptions *) - - and value_description (*IF_CURRENT = Parsetree.value_description *) = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } - - (* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) - *) - - (* Type declarations *) - - and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = - { - ptype_name: string loc; - ptype_params: (core_type * variance) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } - - (* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) - *) - - and type_kind (*IF_CURRENT = Parsetree.type_kind *) = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) - | Ptype_open - - and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l : T [@id1] [@id2] *) - } - - (* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. - *) - - and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = - { - pcd_name: string loc; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - - (* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) - *) - - and type_extension (*IF_CURRENT = Parsetree.type_extension *) = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * variance) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* - type t += ... - *) - - and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = - Pext_decl of constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([T1; ...; Tn], None) - | C: T0 ([], Some T0) - | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) - *) - | Pext_rebind of Longident.t loc - (* - | C = D - *) - - (** {1 Class language} *) - - (* Type expressions for the class language *) - - and class_type (*IF_CURRENT = Parsetree.class_type *) = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = - | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) - | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - | Pcty_open of override_flag * Longident.t loc * class_type - (* let open M in CT *) - - and class_signature (*IF_CURRENT = Parsetree.class_signature *) = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } - (* object('selfpat) ... end - object ... end (self = Ptyp_any) - *) - - and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = - | Pctf_inherit of class_type - (* inherit CT *) - | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) - - and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = - { - pci_virt: virtual_flag; - pci_params: (core_type * variance) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... - - Also used for "class type" declaration. - *) - - and class_description = class_type class_infos - - and class_type_declaration = class_type class_infos - - (* Value expressions for the class language *) - - and class_expr (*IF_CURRENT = Parsetree.class_expr *) = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = - | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - | Pcl_open of override_flag * Longident.t loc * class_expr - (* let open M in CE *) - - - and class_structure (*IF_CURRENT = Parsetree.class_structure *) = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } - (* object(selfpat) ... end - object ... end (self = Ppat_any) - *) - - and class_field (*IF_CURRENT = Parsetree.class_field *) = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_field_desc (*IF_CURRENT = Parsetree.class_field_desc *) = - | Pcf_inherit of override_flag * class_expr * string loc option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) - | Pcf_val of (label loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) - | Pcf_method of (label loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) - - and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - - and class_declaration = class_expr class_infos - - (** {1 Module language} *) - - (* Type expressions for the module language *) - - and module_type (*IF_CURRENT = Parsetree.module_type *) = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) - | Pmty_functor of string loc * module_type option * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) - - and signature = signature_item list - - and signature_item (*IF_CURRENT = Parsetree.signature_item *) = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - - and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = - | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) - | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of extension_constructor - (* exception C of T *) - | Psig_module of module_declaration - (* module X : MT *) - | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) - | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) - | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) - - and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = - { - pmd_name: string loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } - (* S : MT *) - - and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } - (* S = MT - S (abstract module type declaration, pmtd_type = None) - *) - - and open_description (*IF_CURRENT = Parsetree.open_description *) = - { - popen_lid: Longident.t loc; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } - (* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) - - and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - - and include_description = module_type include_infos - (* include MT *) - - and include_declaration = module_expr include_infos - (* include ME *) - - and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = - | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) - | Pwith_typesubst of Longident.t loc * type_declaration - (* with type X.t := ..., same format as [Pwith_type] *) - | Pwith_modsubst of Longident.t loc * Longident.t loc - (* with module X.Y := Z *) - - (* Value expressions for the module language *) - - and module_expr (*IF_CURRENT = Parsetree.module_expr *) = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) - | Pmod_functor of string loc * module_type option * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) - - and structure = structure_item list - - and structure_item (*IF_CURRENT = Parsetree.structure_item *) = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - - and structure_item_desc (*IF_CURRENT = Parsetree.structure_item_desc *) = - | Pstr_eval of expression * attributes - (* E *) - | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) - | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) - | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) - | Pstr_exception of extension_constructor - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) - | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_description - (* open X *) - | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) - | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) - - and value_binding (*IF_CURRENT = Parsetree.value_binding *) = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - - and module_binding (*IF_CURRENT = Parsetree.module_binding *) = - { - pmb_name: string loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } - (* X = ME *) - - (** {1 Toplevel} *) - - (* Toplevel phrases *) - - type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = - | Ptop_def of structure - | Ptop_dir of string * directive_argument - (* #use, #load ... *) - - and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = - | Pdir_none - | Pdir_string of string - | Pdir_int of string * char option - | Pdir_ident of Longident.t - | Pdir_bool of bool - -end - -module Docstrings : sig - (** {2 Docstrings} *) - - (** Documentation comments *) - type docstring - - (** Create a docstring *) - val docstring : string -> Location.t -> docstring - - (** Get the text of a docstring *) - val docstring_body : docstring -> string - - (** Get the location of a docstring *) - val docstring_loc : docstring -> Location.t - - (** {2 Items} - - The {!docs} type represents documentation attached to an item. *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - val empty_docs : docs - - val docs_attr : docstring -> Parsetree.attribute - - (** Convert item documentation to attributes and add them to an - attribute list *) - val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - - (** {2 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - - type info = docstring option - - val empty_info : info - - val info_attr : docstring -> Parsetree.attribute - - (** Convert field info to attributes and add them to an - attribute list *) - val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - - (** {2 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - - type text = docstring list - - val empty_text : text - val empty_text_lazy : text Lazy.t - - val text_attr : docstring -> Parsetree.attribute - - (** Convert text to attributes and add them to an attribute list *) - val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - -end = struct - open Location - - (* Docstrings *) - - type docstring = - { ds_body: string; - ds_loc: Location.t; - } - - (* Docstring constructors and destructors *) - - let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; - } - in - ds - - let docstring_body ds = ds.ds_body - - let docstring_loc ds = ds.ds_loc - - (* Docstrings attached to items *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - let empty_docs = { docs_pre = None; docs_post = None } - - let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - - let docs_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (doc_loc, PStr [item]) - - let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - - (* Docstrings attached to constructors or fields *) - - type info = docstring option - - let empty_info = None - - let info_attr = docs_attr - - let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - - (* Docstrings not attached to a specific item *) - - type text = docstring list - - let empty_text = [] - let empty_text_lazy = lazy [] - - let text_loc = {txt = "ocaml.text"; loc = Location.none} - - let text_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (text_loc, PStr [item]) - - let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""; _} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - -end - -module Ast_helper : sig - - (** Helpers to produce Parsetree fragments *) - - open Asttypes - open Docstrings - open Parsetree - - type lid = Longident.t loc - type str = string loc - type loc = Location.t - type attrs = attribute list - - (** {1 Default locations} *) - - val default_loc: loc ref - (** Default value for all optional location arguments. *) - - val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - - (** {1 Constants} *) - - module Const : sig - val char : char -> constant - val string : ?quotation_delimiter:string -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant - end - - (** {1 Core language} *) - - (** Type expressions *) - module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - - (** Patterns *) - module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - - (** Expressions *) - module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression - -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression - -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - end - - (** Value declarations *) - module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - - (** Type declarations *) - module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * variance) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - - (** Type extensions *) - module Te: - sig - val mk: ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * variance) list -> ?priv:private_flag -> - lid -> extension_constructor list -> type_extension - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - - (** {1 Module language} *) - - (** Module type expressions *) - module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - - (** Module expressions *) - module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - - (** Signature items *) - module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> extension_constructor -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - - (** Structure items *) - module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> extension_constructor -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_description -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - - (** Module declarations *) - module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_type -> module_declaration - end - - (** Module type declarations *) - module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - - (** Module bindings *) - module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_expr -> module_binding - end - - (** Opens *) - module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> lid -> open_description - end - - (** Includes *) - module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - - (** Value bindings *) - module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - - (** {1 Class language} *) - - (** Class type expressions *) - module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_type - -> class_type - end - - (** Class type fields *) - module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - - (** Class expressions *) - module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_expr - -> class_expr - end - - (** Class fields *) - module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - - (** Classes *) - module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> ?params:(core_type * variance) list -> - str -> 'a -> 'a class_infos - end - - (** Class signatures *) - module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - - (** Class structures *) - module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - -end = struct - (**************************************************************************) - (* *) - (* OCaml *) - (* *) - (* Alain Frisch, LexiFi *) - (* *) - (* Copyright 2012 Institut National de Recherche en Informatique et *) - (* en Automatique. *) - (* *) - (* All rights reserved. This file is distributed under the terms of *) - (* the GNU Lesser General Public License version 2.1, with the *) - (* special exception on linking described in the file LICENSE. *) - (* *) - (**************************************************************************) - - (** Helpers to produce Parsetree fragments *) - - open Asttypes - open Parsetree - open Docstrings - - type lid = Longident.t loc - type str = string loc - type loc = Location.t - type attrs = attribute list - - let default_loc = ref Location.none - - let with_default_loc l f = - let old = !default_loc in - default_loc := l; - try let r = f () in default_loc := old; r - with exn -> default_loc := old; raise exn - - module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (string_of_int i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) - end - - module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - - let varify_constructors var_names t = - let check_variable vl loc v = - if List.mem v vl then - raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in - let var_names = List.map (fun v -> v.txt) var_names in - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> - check_variable var_names t.ptyp_loc x; - Ptyp_var x - | Ptyp_arrow (label,core_type,core_type') -> - Ptyp_arrow(label, loop core_type, loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr( { txt = Longident.Lident s; _ }, []) - when List.mem s var_names -> - Ptyp_var s - | Ptyp_constr(longident, lst) -> - Ptyp_constr(longident, List.map loop lst) - | Ptyp_object (lst, o) -> - Ptyp_object (List.map loop_object_field lst, o) - | Ptyp_class (longident, lst) -> - Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) - in - {t with ptyp_desc = desc} - and loop_row_field = - function - | Rtag(label,attrs,flag,lst) -> - Rtag(label,attrs,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - and loop_object_field = - function - | Otag(label, attrs, t) -> - Otag(label, attrs, loop t) - | Oinherit t -> - Oinherit (loop t) - in - loop t - - end - - module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) - end - - module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - end - - module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) - end - - module Mod = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg arg_ty body = - mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) - end - - module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_open (a, b, c)) - end - - module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_open (a, b, c)) - end - - module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - - end - - module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - - end - - module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } - end - - module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } - end - - module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } - end - - module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } - end - - module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) lid = - { - popen_lid = lid; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } - end - - module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - - end - - module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } - end - - module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } - end - - module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - - end - - (** Type extensions *) - module Te = struct - let mk ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - end - - module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } - end - - module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } - end - -end - -module Ast_mapper : sig - (** The interface of a -ppx rewriter - - A -ppx rewriter is a program that accepts a serialized abstract syntax - tree and outputs another, possibly modified, abstract syntax tree. - This module encapsulates the interface between the compiler and - the -ppx rewriters, handling such details as the serialization format, - forwarding of command-line flags, and storing state. - - {!mapper} allows to implement AST rewriting using open recursion. - A typical mapper would be based on {!default_mapper}, a deep - identity mapper, and will fall back on it for handling the syntax it - does not modify. For example: - - {[ - open Asttypes - open Parsetree - open Ast_mapper - - let test_mapper argv = - { default_mapper with - expr = fun mapper expr -> - match expr with - | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> - Ast_helper.Exp.constant (Const_int 42) - | other -> default_mapper.expr mapper other; } - - let () = - register "ppx_test" test_mapper]} - - This -ppx rewriter, which replaces [[%test]] in expressions with - the constant [42], can be compiled using - [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. - - *) - - open Parsetree - - (** {1 A generic Parsetree mapper} *) - - type mapper (*IF_CURRENT = Ast_mapper.mapper*) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - (** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - - val default_mapper: mapper - (** A default mapper, which implements a "deep identity" mapping. *) - - (** {1 Convenience functions to write mappers} *) - - val map_opt: ('a -> 'b) -> 'a option -> 'b option - - val extension_of_error: Locations.location_error -> extension - (** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) - - val attribute_of_warning: Location.t -> string -> attribute - (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) - - include Locations.Helpers_intf - -end = struct - (* A generic Parsetree mapping class *) - - (* - [@@@ocaml.warning "+9"] - (* Ensure that record patterns don't miss any field. *) - *) - - - open Parsetree - open Ast_helper - open Location - - type mapper (*IF_CURRENT = Ast_mapper.mapper*) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - - let map_fst f (x, y) = (f x, y) - let map_snd f (x, y) = (x, f y) - let map_tuple f1 f2 (x, y) = (f1 x, f2 y) - let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) - let map_opt f = function None -> None | Some x -> Some (f x) - - let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - - module T = struct - (* Type expressions for the core language *) - - let row_field sub = function - | Rtag (l, attrs, b, tl) -> - Rtag (map_loc sub l, sub.attributes sub attrs, - b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - - let object_field sub = function - | Otag (l, attrs, t) -> - Otag (map_loc sub l, sub.attributes sub attrs, sub.typ sub t) - | Oinherit t -> Oinherit (sub.typ sub t) - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs - (List.map (map_loc sub) sl) (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - Type.mk (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - ~loc:(sub.location sub ptype_loc) - ~attrs:(sub.attributes sub ptype_attributes) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_attributes} = - Te.mk - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - ~attrs:(sub.attributes sub ptyext_attributes) - - let map_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - Te.constructor - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - ~loc:(sub.location sub pext_loc) - ~attrs:(sub.attributes sub pext_attributes) - - end - - module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (ovf, lid, ct) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_type sub ct) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) - end - - module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (s, mt1, mt2) -> - functor_ ~loc ~attrs (map_loc sub s) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) mt1) - (sub.module_type sub mt2) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) - end - - - module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (arg, arg_ty, body) -> - functor_ ~loc ~attrs (map_loc sub arg) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) arg_ty) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_description sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) - end - - module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs x - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> - send ~loc ~attrs (sub.expr sub e) (map_loc sub s) - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (ovf, lid, e) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () - end - - module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs c - | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) - end - - module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (ovf, lid, ce) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_expr sub ce) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> - inherit_ ~loc ~attrs o (sub.class_expr sub ce) - (map_opt (map_loc sub) s) - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - Ci.mk - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) - ~loc:(sub.location sub pci_loc) - ~attrs:(sub.attributes sub pci_attributes) - end - - (* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - - let default_mapper = - { - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_description = - (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_lid) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - - let extension_of_error (error : Locations.location_error) : extension = - Locations.extension_of_error - ~mk_pstr:(function - | x :: l -> PStr (x :: x :: l) - | l -> PStr l) - ~mk_extension:(fun x -> Str.extension x) - ~mk_string_constant:(fun x -> Str.eval (Exp.constant (Pconst_string (x, None)))) - error - - let attribute_of_warning loc s = - { loc; txt = "ocaml.ppwarning" }, - PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, None)))]) - - include Locations.Helpers_impl - -end - module Outcometree = struct (* Module [Outcometree]: results displayed by the toplevel *) @@ -2990,110 +208,3 @@ module Outcometree = struct | Ophr_exception of (exn * out_value) end - -module Config = struct - let ast_impl_magic_number = "Caml1999M023" - let ast_intf_magic_number = "Caml1999N023" -end - -let map_signature mapper = mapper.Ast_mapper.signature mapper -let map_structure mapper = mapper.Ast_mapper.structure mapper - -let shallow_identity = - let id _ x = x in - { - Ast_mapper. - structure = id; - structure_item = id; - module_expr = id; - signature = id; - signature_item = id; - module_type = id; - with_constraint = id; - class_declaration = id; - class_expr = id; - class_field = id; - class_structure = id; - class_type = id; - class_type_field = id; - class_signature = id; - class_type_declaration = id; - class_description = id; - type_declaration = id; - type_kind = id; - typ = id; - type_extension = id; - extension_constructor = id; - value_description = id; - pat = id; - expr = id; - module_declaration = id; - module_type_declaration = id; - module_binding = id; - open_description = id; - include_description = id; - include_declaration = id; - value_binding = id; - constructor_declaration = id; - label_declaration = id; - cases = id; - case = id; - location = id; - extension = id; - attribute = id; - attributes = id; - payload = id; - } - -let failing_mapper = - let fail _ _ = - invalid_arg "failing_mapper: this mapper function should never get called" - in - { - Ast_mapper. - structure = fail; - structure_item = fail; - module_expr = fail; - signature = fail; - signature_item = fail; - module_type = fail; - with_constraint = fail; - class_declaration = fail; - class_expr = fail; - class_field = fail; - class_structure = fail; - class_type = fail; - class_type_field = fail; - class_signature = fail; - class_type_declaration = fail; - class_description = fail; - type_declaration = fail; - type_kind = fail; - typ = fail; - type_extension = fail; - extension_constructor = fail; - value_description = fail; - pat = fail; - expr = fail; - module_declaration = fail; - module_type_declaration = fail; - module_binding = fail; - open_description = fail; - include_description = fail; - include_declaration = fail; - value_binding = fail; - constructor_declaration = fail; - label_declaration = fail; - cases = fail; - case = fail; - location = fail; - extension = fail; - attribute = fail; - attributes = fail; - payload = fail; - } - -let make_top_mapper ~signature ~structure = - {failing_mapper with Ast_mapper. - signature = (fun _ x -> signature x); - structure = (fun _ x -> structure x) } diff --git a/src/vendored-omp/src/ast_408.ml b/src/vendored-omp/src/ast_408.ml index 97ed6ce09..511d1823b 100644 --- a/src/vendored-omp/src/ast_408.ml +++ b/src/vendored-omp/src/ast_408.ml @@ -28,3877 +28,53 @@ Actually run all lib-unix tests [4.08] *) -open Stdlib0 -open Ast_408_helper - -module Location = Location -module Longident = Longident - -module Asttypes = struct - - type constant (*IF_CURRENT = Asttypes.constant *) = - Const_int of int - | Const_char of char - | Const_string of string * string option - | Const_float of string - | Const_int32 of int32 - | Const_int64 of int64 - | Const_nativeint of nativeint - - type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive - - type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto - - (* Order matters, used in polymorphic comparison *) - type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - - type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - - type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - - type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh - - type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open - - type label = string - - type arg_label (*IF_CURRENT = Asttypes.arg_label *) = - Nolabel - | Labelled of string (* label:T -> ... *) - | Optional of string (* ?label:T -> ... *) - - type 'a loc = 'a Location.loc = { - txt : 'a; - loc : Location.t; - } - - - type variance (*IF_CURRENT = Asttypes.variance *) = - | Covariant - | Contravariant - | Invariant - -end - -module Parsetree = struct - - open Asttypes - - type constant (*IF_CURRENT = Parsetree.constant *) = - Pconst_integer of string * char option - (* 3 3l 3L 3n - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker - *) - | Pconst_char of char - (* 'c' *) - | Pconst_string of string * string option - (* "constant" - {delim|other constant|delim} - *) - | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - - (** {1 Extension points} *) - - type attribute (*IF_CURRENT = Parsetree.attribute *) = { - attr_name : string loc; - attr_payload : payload; - attr_loc : Location.t; - } - (* [@id ARG] - [@@id ARG] - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - - and extension = string loc * payload - (* [%id ARG] - [%%id ARG] - - Sub-language placeholder -- rejected by the typechecker. - *) - - and attributes = attribute list - - and payload (*IF_CURRENT = Parsetree.payload *) = - | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - - (** {1 Core language} *) - - (* Type expressions *) - - and core_type (*IF_CURRENT = Parsetree.core_type *) = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_loc_stack: Location.t list; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and typ = core_type - - and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional - *) - | Ptyp_tuple of core_type list - (* T1 * ... * Tn - - Invariant: n >= 2 - *) - | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of object_field list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). - - - As the core_type of a Pctf_method node. - - - As the core_type of a Pexp_poly node. - - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) - - and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) - - and row_field (*IF_CURRENT = Parsetree.row_field *) = { - prf_desc : row_field_desc; - prf_loc : Location.t; - prf_attributes : attributes; - } - - and row_field_desc (*IF_CURRENT = Parsetree.row_field_desc *) = - | Rtag of label loc * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 'bool' field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - *) - | Rinherit of core_type - (* [ T ] *) - - and object_field (*IF_CURRENT = Parsetree.object_field *) = { - pof_desc : object_field_desc; - pof_loc : Location.t; - pof_attributes : attributes; - } - - and object_field_desc (*IF_CURRENT = Parsetree.object_field_desc *) = - | Otag of label loc * core_type - | Oinherit of core_type - - (* Patterns *) - - and pattern (*IF_CURRENT = Parsetree.pattern *) = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_loc_stack: Location.t list; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and pat = pattern - - and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Ppat_interval of constant * constant - (* 'a'..'z' - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (* (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Ppat_construct of Longident.t loc * pattern option - (* C None - C P Some P - C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) - *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) - | Ppat_unpack of string loc - (* (module P) - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of Longident.t loc * pattern - (* M.(P) *) - - (* Value expressions *) - - and expression (*IF_CURRENT = Parsetree.expression *) = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_loc_stack: Location.t list; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and expr = expression - - and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = - | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of cases - (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) - | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pexp_match of expression * cases - (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * cases - (* try E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_tuple of expression list - (* (E1, ..., En) - - Invariant: n >= 2 - *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) - | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) - | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * label loc - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of label loc * expression - (* x <- 2 *) - | Pexp_override of (label loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) - | Pexp_letmodule of string loc * module_expr * expression - (* let module M = ME in E *) - | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) - | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) - | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string loc * expression - (* fun (type t) -> E *) - | Pexp_pack of module_expr - (* (module ME) - - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of open_declaration * expression - (* M.(E) - let open M in E - let! open M in E *) - | Pexp_letop of letop - (* let* P = E in E - let* P = E and* P = E in E *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable - (* . *) - - and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - - and cases = case list - - and letop (*IF_CURRENT = Parsetree.letop *) = - { - let_ : binding_op; - ands : binding_op list; - body : expression; - } - - and binding_op (*IF_CURRENT = Parsetree.binding_op *) = - { - pbop_op : string loc; - pbop_pat : pattern; - pbop_exp : expression; - pbop_loc : Location.t; - } - - (* Value descriptions *) - - and value_description (*IF_CURRENT = Parsetree.value_description *) = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } - -(* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) - *) - - (* Type declarations *) - - and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = - { - ptype_name: string loc; - ptype_params: (core_type * variance) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } - -(* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) - *) - - and type_kind (*IF_CURRENT = Parsetree.type_kind *) = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) - | Ptype_open - - and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l : T [@id1] [@id2] *) - } - - (* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. - *) - - and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = - { - pcd_name: string loc; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - -(* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) - *) - - and type_extension (*IF_CURRENT = Parsetree.type_extension *) = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * variance) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_loc: Location.t; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } -(* - type t += ... - *) - - and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - (* exception E *) - and type_exception (*IF_CURRENT = Parsetree.type_exception *) = - { - ptyexn_constructor: extension_constructor; - ptyexn_loc: Location.t; - ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = - Pext_decl of constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([T1; ...; Tn], None) - | C: T0 ([], Some T0) - | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) - *) - | Pext_rebind of Longident.t loc - (* - | C = D - *) - - (** {1 Class language} *) - - (* Type expressions for the class language *) - - and class_type (*IF_CURRENT = Parsetree.class_type *) = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = - | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) - | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - | Pcty_open of open_description * class_type - (* let open M in CT *) - - and class_signature (*IF_CURRENT = Parsetree.class_signature *) = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } - (* object('selfpat) ... end - object ... end (self = Ptyp_any) - *) - - and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = - | Pctf_inherit of class_type - (* inherit CT *) - | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) - - and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = - { - pci_virt: virtual_flag; - pci_params: (core_type * variance) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... - - Also used for "class type" declaration. - *) - - and class_description = class_type class_infos - - and class_type_declaration = class_type class_infos - - (* Value expressions for the class language *) - - and class_expr (*IF_CURRENT = Parsetree.class_expr *) = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = - | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - | Pcl_open of open_description * class_expr - (* let open M in CE *) - - - and class_structure (*IF_CURRENT = Parsetree.class_structure *) = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } - (* object(selfpat) ... end - object ... end (self = Ppat_any) - *) - - and class_field (*IF_CURRENT = Parsetree.class_field *) = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_field_desc (*IF_CURRENT = Parsetree.class_field_desc *) = - | Pcf_inherit of override_flag * class_expr * string loc option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) - | Pcf_val of (label loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) - | Pcf_method of (label loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) - - and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - - and class_declaration = class_expr class_infos - - (** {1 Module language} *) - - (* Type expressions for the module language *) - - and module_type (*IF_CURRENT = Parsetree.module_type *) = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) - | Pmty_functor of string loc * module_type option * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) - - and signature = signature_item list - - and signature_item (*IF_CURRENT = Parsetree.signature_item *) = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - - and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = - | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) - | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typesubst of type_declaration list - (* type t1 := ... and ... and tn := ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of type_exception - (* exception C of T *) - | Psig_module of module_declaration - (* module X = M - module X : MT *) - | Psig_modsubst of module_substitution - (* module X := M *) - | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) - | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) - | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) - - and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = - { - pmd_name: string loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } - (* S : MT *) - - and module_substitution (*IF_CURRENT = Parsetree.module_substitution *) = - { - pms_name: string loc; - pms_manifest: Longident.t loc; - pms_attributes: attributes; (* ... [@@id1] [@@id2] *) - pms_loc: Location.t; - } - - and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } - (* S = MT - S (abstract module type declaration, pmtd_type = None) - *) - - and 'a open_infos (*IF_CURRENT = 'a Parsetree.open_infos *) = - { - popen_expr: 'a; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } - (* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) - - and open_description = Longident.t loc open_infos - (* open M.N - open M(N).O *) - - and open_declaration = module_expr open_infos - (* open M.N - open M(N).O - open struct ... end *) - - and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - - and include_description = module_type include_infos - (* include MT *) - - and include_declaration = module_expr include_infos - (* include ME *) - - and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = - | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) - | Pwith_typesubst of Longident.t loc * type_declaration - (* with type X.t := ..., same format as [Pwith_type] *) - | Pwith_modsubst of Longident.t loc * Longident.t loc - (* with module X.Y := Z *) - - (* Value expressions for the module language *) - - and module_expr (*IF_CURRENT = Parsetree.module_expr *) = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) - | Pmod_functor of string loc * module_type option * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) - - and structure = structure_item list - - and structure_item (*IF_CURRENT = Parsetree.structure_item *) = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - - and structure_item_desc (*IF_CURRENT = Parsetree.structure_item_desc *) = - | Pstr_eval of expression * attributes - (* E *) - | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) - | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) - | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) - | Pstr_exception of type_exception - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) - | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_declaration - (* open X *) - | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) - | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) - - and value_binding (*IF_CURRENT = Parsetree.value_binding *) = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - - and module_binding (*IF_CURRENT = Parsetree.module_binding *) = - { - pmb_name: string loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } - (* X = ME *) - - (** {1 Toplevel} *) - - (* Toplevel phrases *) - - type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = - | Ptop_def of structure - | Ptop_dir of toplevel_directive - (* #use, #load ... *) - - and toplevel_directive (*IF_CURRENT = Parsetree.toplevel_directive *) = - { - pdir_name : string loc; - pdir_arg : directive_argument option; - pdir_loc : Location.t; - } - - and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = - { - pdira_desc : directive_argument_desc; - pdira_loc : Location.t; - } - - and directive_argument_desc (*IF_CURRENT = Parsetree.directive_argument_desc *) = - | Pdir_string of string - | Pdir_int of string * char option - | Pdir_ident of Longident.t - | Pdir_bool of bool - -end - -module Docstrings : sig - (** (Re)Initialise all docstring state *) - val init : unit -> unit - - (** Emit warnings for unattached and ambiguous docstrings *) - val warn_bad_docstrings : unit -> unit - - (** {2 Docstrings} *) - - (** Documentation comments *) - type docstring - - (** Create a docstring *) - val docstring : string -> Location.t -> docstring - - (** Register a docstring *) - val register : docstring -> unit - - (** Get the text of a docstring *) - val docstring_body : docstring -> string - - (** Get the location of a docstring *) - val docstring_loc : docstring -> Location.t - - (** {2 Set functions} - - These functions are used by the lexer to associate docstrings to - the locations of tokens. *) - - (** Docstrings immediately preceding a token *) - val set_pre_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately following a token *) - val set_post_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings not immediately adjacent to a token *) - val set_floating_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately following the token which precedes this one *) - val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately preceding the token which follows this one *) - val set_post_extra_docstrings : Lexing.position -> docstring list -> unit - - (** {2 Items} - - The {!docs} type represents documentation attached to an item. *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - val empty_docs : docs - - val docs_attr : docstring -> Parsetree.attribute - - (** Convert item documentation to attributes and add them to an - attribute list *) - val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) - val symbol_docs : unit -> docs - val symbol_docs_lazy : unit -> docs Lazy.t - - (** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) - val rhs_docs : int -> int -> docs - val rhs_docs_lazy : int -> int -> docs Lazy.t - - (** Mark the item documentation for the current symbol (for ambiguity - warnings). *) - val mark_symbol_docs : unit -> unit - - (** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) - val mark_rhs_docs : int -> int -> unit - - (** {2 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - - type info = docstring option - - val empty_info : info - - val info_attr : docstring -> Parsetree.attribute - - (** Convert field info to attributes and add them to an - attribute list *) - val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the field info for the current symbol. *) - val symbol_info : unit -> info - - (** Fetch the field info following the symbol at a given position. *) - val rhs_info : int -> info - - (** {2 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - - type text = docstring list - - val empty_text : text - val empty_text_lazy : text Lazy.t - - val text_attr : docstring -> Parsetree.attribute - - (** Convert text to attributes and add them to an attribute list *) - val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the text preceding the current symbol. *) - val symbol_text : unit -> text - val symbol_text_lazy : unit -> text Lazy.t - - (** Fetch the text preceding the symbol at the given position. *) - val rhs_text : int -> text - val rhs_text_lazy : int -> text Lazy.t - - (** {2 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - - (** Fetch additional text preceding the current symbol *) - val symbol_pre_extra_text : unit -> text - - (** Fetch additional text following the current symbol *) - val symbol_post_extra_text : unit -> text - - (** Fetch additional text preceding the symbol at the given position *) - val rhs_pre_extra_text : int -> text - - (** Fetch additional text following the symbol at the given position *) - val rhs_post_extra_text : int -> text - - (** Fetch text following the symbol at the given position *) - val rhs_post_text : int -> text - - module WithMenhir: sig - (** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) - val symbol_docs : Lexing.position * Lexing.position -> docs - val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t - - (** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) - val rhs_docs : Lexing.position -> Lexing.position -> docs - val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t - - (** Mark the item documentation for the current symbol (for ambiguity - warnings). *) - val mark_symbol_docs : Lexing.position * Lexing.position -> unit - - (** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) - val mark_rhs_docs : Lexing.position -> Lexing.position -> unit - - (** Fetch the field info for the current symbol. *) - val symbol_info : Lexing.position -> info - - (** Fetch the field info following the symbol at a given position. *) - val rhs_info : Lexing.position -> info - - (** Fetch the text preceding the current symbol. *) - val symbol_text : Lexing.position -> text - val symbol_text_lazy : Lexing.position -> text Lazy.t - - (** Fetch the text preceding the symbol at the given position. *) - val rhs_text : Lexing.position -> text - val rhs_text_lazy : Lexing.position -> text Lazy.t - - (** {3 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - - (** Fetch additional text preceding the current symbol *) - val symbol_pre_extra_text : Lexing.position -> text - - (** Fetch additional text following the current symbol *) - val symbol_post_extra_text : Lexing.position -> text - - (** Fetch additional text preceding the symbol at the given position *) - val rhs_pre_extra_text : Lexing.position -> text - - (** Fetch additional text following the symbol at the given position *) - val rhs_post_extra_text : Lexing.position -> text - - (** Fetch text following the symbol at the given position *) - val rhs_post_text : Lexing.position -> text - - end -end = struct - open Location - - (* Docstrings *) - - (* A docstring is "attached" if it has been inserted in the AST. This - is used for generating unexpected docstring warnings. *) - type ds_attached = - | Unattached (* Not yet attached anything.*) - | Info (* Attached to a field or constructor. *) - | Docs (* Attached to an item or as floating text. *) - - (* A docstring is "associated" with an item if there are no blank lines between - them. This is used for generating docstring ambiguity warnings. *) - type ds_associated = - | Zero (* Not associated with an item *) - | One (* Associated with one item *) - | Many (* Associated with multiple items (ambiguity) *) - - type docstring = - { ds_body: string; - ds_loc: Location.t; - mutable ds_attached: ds_attached; - mutable ds_associated: ds_associated; } - - (* List of docstrings *) - - let docstrings : docstring list ref = ref [] - - (* Warn for unused and ambiguous docstrings *) - - let warn_bad_docstrings () = - if Warnings.is_active (Migrate_parsetree_compiler_functions.bad_docstring true) then begin - List.iter - (fun ds -> - match ds.ds_attached with - | Info -> () - | Unattached -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring true) - | Docs -> - match ds.ds_associated with - | Zero | One -> () - | Many -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring false)) - (List.rev !docstrings) - end - - (* Docstring constructors and destructors *) - - let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; - ds_attached = Unattached; - ds_associated = Zero; } - in - ds - - let register ds = - docstrings := ds :: !docstrings - - let docstring_body ds = ds.ds_body - - let docstring_loc ds = ds.ds_loc - - (* Docstrings attached to items *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - let empty_docs = { docs_pre = None; docs_post = None } - - let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - - let docs_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - { attr_name = doc_loc; - attr_payload = PStr [item]; - attr_loc = Location.none } - - let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - - (* Docstrings attached to constructors or fields *) - - type info = docstring option - - let empty_info = None - - let info_attr = docs_attr - - let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - - (* Docstrings not attached to a specific item *) - - type text = docstring list - - let empty_text = [] - let empty_text_lazy = lazy [] - - let text_loc = {txt = "ocaml.text"; loc = Location.none} - - let text_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - { attr_name = text_loc; - attr_payload = PStr [item]; - attr_loc = Location.none } - - let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""; _} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - - (* Find the first non-info docstring in a list, attach it and return it *) - let get_docstring ~info dsl = - let rec loop = function - | [] -> None - | {ds_attached = Info; _} :: rest -> loop rest - | ds :: _ -> - ds.ds_attached <- if info then Info else Docs; - Some ds - in - loop dsl - - (* Find all the non-info docstrings in a list, attach them and return them *) - let get_docstrings dsl = - let rec loop acc = function - | [] -> List.rev acc - | {ds_attached = Info; _} :: rest -> loop acc rest - | ds :: rest -> - ds.ds_attached <- Docs; - loop (ds :: acc) rest - in - loop [] dsl - - (* "Associate" all the docstrings in a list *) - let associate_docstrings dsl = - List.iter - (fun ds -> - match ds.ds_associated with - | Zero -> ds.ds_associated <- One - | (One | Many) -> ds.ds_associated <- Many) - dsl - - (* Map from positions to pre docstrings *) - - let pre_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_pre_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_table pos dsl - - let get_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - - let mark_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl - with Not_found -> () - - (* Map from positions to post docstrings *) - - let post_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_post_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_table pos dsl - - let get_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - - let mark_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl - with Not_found -> () - - let get_info pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstring ~info:true dsl - with Not_found -> None - - (* Map from positions to floating docstrings *) - - let floating_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_floating_docstrings pos dsl = - if dsl <> [] then Hashtbl.add floating_table pos dsl - - let get_text pos = - try - let dsl = Hashtbl.find floating_table pos in - get_docstrings dsl - with Not_found -> [] - - let get_post_text pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstrings dsl - with Not_found -> [] - - (* Maps from positions to extra docstrings *) - - let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_pre_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_extra_table pos dsl - - let get_pre_extra_text pos = - try - let dsl = Hashtbl.find pre_extra_table pos in - get_docstrings dsl - with Not_found -> [] - - let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_post_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_extra_table pos dsl - - let get_post_extra_text pos = - try - let dsl = Hashtbl.find post_extra_table pos in - get_docstrings dsl - with Not_found -> [] - - (* Docstrings from parser actions *) - module WithParsing = struct - let symbol_docs () = - { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); - docs_post = get_post_docs (Parsing.symbol_end_pos ()); } - - let symbol_docs_lazy () = - let p1 = Parsing.symbol_start_pos () in - let p2 = Parsing.symbol_end_pos () in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); - docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } - - let rhs_docs_lazy pos1 pos2 = - let p1 = Parsing.rhs_start_pos pos1 in - let p2 = Parsing.rhs_end_pos pos2 in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let mark_symbol_docs () = - mark_pre_docs (Parsing.symbol_start_pos ()); - mark_post_docs (Parsing.symbol_end_pos ()) - - let mark_rhs_docs pos1 pos2 = - mark_pre_docs (Parsing.rhs_start_pos pos1); - mark_post_docs (Parsing.rhs_end_pos pos2) - - let symbol_info () = - get_info (Parsing.symbol_end_pos ()) - - let rhs_info pos = - get_info (Parsing.rhs_end_pos pos) - - let symbol_text () = - get_text (Parsing.symbol_start_pos ()) - - let symbol_text_lazy () = - let pos = Parsing.symbol_start_pos () in - lazy (get_text pos) - - let rhs_text pos = - get_text (Parsing.rhs_start_pos pos) - - let rhs_post_text pos = - get_post_text (Parsing.rhs_end_pos pos) - - let rhs_text_lazy pos = - let pos = Parsing.rhs_start_pos pos in - lazy (get_text pos) - - let symbol_pre_extra_text () = - get_pre_extra_text (Parsing.symbol_start_pos ()) - - let symbol_post_extra_text () = - get_post_extra_text (Parsing.symbol_end_pos ()) - - let rhs_pre_extra_text pos = - get_pre_extra_text (Parsing.rhs_start_pos pos) - - let rhs_post_extra_text pos = - get_post_extra_text (Parsing.rhs_end_pos pos) - end - - include WithParsing - - module WithMenhir = struct - let symbol_docs (startpos, endpos) = - { docs_pre = get_pre_docs startpos; - docs_post = get_post_docs endpos; } - - let symbol_docs_lazy (p1, p2) = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs pos1; - docs_post = get_post_docs pos2; } - - let rhs_docs_lazy p1 p2 = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let mark_symbol_docs (startpos, endpos) = - mark_pre_docs startpos; - mark_post_docs endpos; - () - - let mark_rhs_docs pos1 pos2 = - mark_pre_docs pos1; - mark_post_docs pos2; - () - - let symbol_info endpos = - get_info endpos - - let rhs_info endpos = - get_info endpos - - let symbol_text startpos = - get_text startpos - - let symbol_text_lazy startpos = - lazy (get_text startpos) - - let rhs_text pos = - get_text pos - - let rhs_post_text pos = - get_post_text pos - - let rhs_text_lazy pos = - lazy (get_text pos) - - let symbol_pre_extra_text startpos = - get_pre_extra_text startpos - - let symbol_post_extra_text endpos = - get_post_extra_text endpos - - let rhs_pre_extra_text pos = - get_pre_extra_text pos - - let rhs_post_extra_text pos = - get_post_extra_text pos - end - - (* (Re)Initialise all comment state *) - - let init () = - docstrings := []; - Hashtbl.reset pre_table; - Hashtbl.reset post_table; - Hashtbl.reset floating_table; - Hashtbl.reset pre_extra_table; - Hashtbl.reset post_extra_table -end - -module Ast_helper : sig - open Asttypes - open Docstrings - open Parsetree - - type 'a with_loc = 'a Location.loc - type loc = Location.t - - type lid = Longident.t with_loc - type str = string with_loc - type attrs = attribute list - - (** {1 Default locations} *) - - val default_loc: loc ref - (** Default value for all optional location arguments. *) - - val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - - (** {1 Constants} *) - - module Const : sig - val char : char -> constant - val string : ?quotation_delimiter:string -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant - end - - (** {1 Attributes} *) - module Attr : sig - val mk: ?loc:loc -> str -> payload -> attribute - end - - (** {1 Core language} *) - - (** Type expressions *) - module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - - (** Patterns *) - module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - - (** Expressions *) - module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> cases -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> cases - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> cases -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression - -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression - -> expression - val letop: ?loc:loc -> ?attrs:attrs -> binding_op - -> binding_op list -> expression -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - val binding_op: str -> pattern -> expression -> loc -> binding_op - end - - (** Value declarations *) - module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - - (** Type declarations *) - module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * variance) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - - (** Type extensions *) - module Te: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * variance) list -> ?priv:private_flag -> - lid -> extension_constructor list -> type_extension - - val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - extension_constructor -> type_exception - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - - (** {1 Module language} *) - - (** Module type expressions *) - module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - - (** Module expressions *) - module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - - (** Signature items *) - module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_subst: ?loc:loc -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> type_exception -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val mod_subst: ?loc:loc -> module_substitution -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - - (** Structure items *) - module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> type_exception -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_declaration -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - - (** Module declarations *) - module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_type -> module_declaration - end - - (** Module substitutions *) - module Ms: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> lid -> module_substitution - end - - (** Module type declarations *) - module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - - (** Module bindings *) - module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_expr -> module_binding - end - - (** Opens *) - module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> 'a -> 'a open_infos - end - - (** Includes *) - module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - - (** Value bindings *) - module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - - (** {1 Class language} *) - - (** Class type expressions *) - module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type - -> class_type - end - - (** Class type fields *) - module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - - (** Class expressions *) - module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr - -> class_expr - end - - (** Class fields *) - module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - - (** Classes *) - module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> ?params:(core_type * variance) list -> - str -> 'a -> 'a class_infos - end - - (** Class signatures *) - module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - - (** Class structures *) - module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - - (** Row fields *) - module Rf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> bool -> core_type list -> row_field - val inherit_: ?loc:loc -> core_type -> row_field - end - - (** Object fields *) - module Of: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - object_field_desc -> object_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> core_type -> object_field - val inherit_: ?loc:loc -> core_type -> object_field - end -end = struct - open Asttypes - open Parsetree - open Docstrings - - type 'a with_loc = 'a Location.loc - type loc = Location.t - - type lid = Longident.t with_loc - type str = string with_loc - type attrs = attribute list - - let default_loc = ref Location.none - - let with_default_loc l f = - Misc.protect_refs [Misc.R (default_loc, l)] f - - module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (Int.to_string i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) - end - - module Attr = struct - let mk ?(loc= !default_loc) name payload = - { attr_name = name; - attr_payload = payload; - attr_loc = loc } - end - - module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; - ptyp_loc = loc; - ptyp_loc_stack = []; - ptyp_attributes = attrs} - - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - - let varify_constructors var_names t = - let check_variable vl loc v = - if List.mem v vl then - raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in - let var_names = List.map (fun v -> v.txt) var_names in - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> - check_variable var_names t.ptyp_loc x; - Ptyp_var x - | Ptyp_arrow (label,core_type,core_type') -> - Ptyp_arrow(label, loop core_type, loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr( { txt = Longident.Lident s; _ }, []) - when List.mem s var_names -> - Ptyp_var s - | Ptyp_constr(longident, lst) -> - Ptyp_constr(longident, List.map loop lst) - | Ptyp_object (lst, o) -> - Ptyp_object (List.map loop_object_field lst, o) - | Ptyp_class (longident, lst) -> - Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) - in - {t with ptyp_desc = desc} - and loop_row_field field = - let prf_desc = match field.prf_desc with - | Rtag(label,flag,lst) -> - Rtag(label,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - in - { field with prf_desc; } - and loop_object_field field = - let pof_desc = match field.pof_desc with - | Otag(label, t) -> - Otag(label, loop t) - | Oinherit t -> - Oinherit (loop t) - in - { field with pof_desc; } - in - loop t - - end - - module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; - ppat_loc = loc; - ppat_loc_stack = []; - ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) - end - - module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b)) - let letop ?loc ?attrs let_ ands body = - mk ?loc ?attrs (Pexp_letop {let_; ands; body}) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - - let binding_op op pat exp loc = - { - pbop_op = op; - pbop_pat = pat; - pbop_exp = exp; - pbop_loc = loc; - } - end - - module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) - end - - module Mod = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg arg_ty body = - mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) - end - - module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_subst ?loc a = mk ?loc (Psig_typesubst a) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let mod_subst ?loc a = mk ?loc (Psig_modsubst a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b)) - end - - module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b)) - end - - module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - - end - - module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - - end - - module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } - end - - module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } - end - - module Ms = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name syn = - { - pms_name = name; - pms_manifest = syn; - pms_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pms_loc = loc; - } - end - - module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } - end - - module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } - end - - module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) expr = - { - popen_expr = expr; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } - end - - module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - - end - - module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } - end - - module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } - end - - module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - - end - - (** Type extensions *) - module Te = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_loc = loc; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - constructor = - { - ptyexn_constructor = constructor; - ptyexn_loc = loc; - ptyexn_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - end - - module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } - end - - module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } - end - - (** Row fields *) - module Rf = struct - let mk ?(loc = !default_loc) ?(attrs = []) desc = { - prf_desc = desc; - prf_loc = loc; - prf_attributes = attrs; - } - let tag ?loc ?attrs label const tys = - mk ?loc ?attrs (Rtag (label, const, tys)) - let inherit_?loc ty = - mk ?loc (Rinherit ty) - end - - (** Object fields *) - module Of = struct - let mk ?(loc = !default_loc) ?(attrs=[]) desc = { - pof_desc = desc; - pof_loc = loc; - pof_attributes = attrs; - } - let tag ?loc ?attrs label ty = - mk ?loc ?attrs (Otag (label, ty)) - let inherit_ ?loc ty = - mk ?loc (Oinherit ty) - end -end - -module Ast_mapper : sig - open Parsetree - - (** {1 A generic Parsetree mapper} *) - - type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> cases -> cases; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - (** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - - val default_mapper: mapper - (** A default mapper, which implements a "deep identity" mapping. *) - - (** {1 Apply mappers to compilation units} *) - - val tool_name: unit -> string - (** Can be used within a ppx preprocessor to know which tool is - calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], - ["ocaml"], ... Some global variables that reflect command-line - options are automatically synchronized between the calling tool - and the ppx preprocessor: {!Clflags.include_dirs}, - {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package}, - {!Clflags.debug}. *) - - - val apply: source:string -> target:string -> mapper -> unit - (** Apply a mapper (parametrized by the unit name) to a dumped - parsetree found in the [source] file and put the result in the - [target] file. The [structure] or [signature] field of the mapper - is applied to the implementation or interface. *) - - val run_main: (string list -> mapper) -> unit - (** Entry point to call to implement a standalone -ppx rewriter from a - mapper, parametrized by the command line arguments. The current - unit name can be obtained from {!Location.input_name}. This - function implements proper error reporting for uncaught - exceptions. *) - - (** {1 Registration API} *) - - val register_function: (string -> (string list -> mapper) -> unit) ref - - val register: string -> (string list -> mapper) -> unit - (** Apply the [register_function]. The default behavior is to run the - mapper immediately, taking arguments from the process command - line. This is to support a scenario where a mapper is linked as a - stand-alone executable. - - It is possible to overwrite the [register_function] to define - "-ppx drivers", which combine several mappers in a single process. - Typically, a driver starts by defining [register_function] to a - custom implementation, then lets ppx rewriters (linked statically - or dynamically) register themselves, and then run all or some of - them. It is also possible to have -ppx drivers apply rewriters to - only specific parts of an AST. - - The first argument to [register] is a symbolic name to be used by - the ppx driver. *) - - - (** {1 Convenience functions to write mappers} *) - - val map_opt: ('a -> 'b) -> 'a option -> 'b option - - val extension_of_error: Locations.location_error -> extension - (** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) +module Location = Location +module Longident = Longident - val attribute_of_warning: Location.t -> string -> attribute - (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) +module Asttypes = struct - include Locations.Helpers_intf + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * string option + | Const_float of string + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint - (** {1 Helper functions to call external mappers} *) + type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive - val add_ppx_context_str: - tool_name:string -> Parsetree.structure -> Parsetree.structure - (** Extract information from the current environment and encode it - into an attribute which is prepended to the list of structure - items in order to pass the information to an external - processor. *) + type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto - val add_ppx_context_sig: - tool_name:string -> Parsetree.signature -> Parsetree.signature - (** Same as [add_ppx_context_str], but for signatures. *) + (* Order matters, used in polymorphic comparison *) + type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - val drop_ppx_context_str: - restore:bool -> Parsetree.structure -> Parsetree.structure - (** Drop the ocaml.ppx.context attribute from a structure. If - [restore] is true, also restore the associated data in the current - process. *) + type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - val drop_ppx_context_sig: - restore:bool -> Parsetree.signature -> Parsetree.signature - (** Same as [drop_ppx_context_str], but for signatures. *) + type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - (** {1 Cookies} *) + type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh - (** Cookies are used to pass information from a ppx processor to - a further invocation of itself, when called from the OCaml - toplevel (or other tools that support cookies). *) + type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open - val set_cookie: string -> Parsetree.expression -> unit - val get_cookie: string -> Parsetree.expression option -end = struct - open Parsetree - open Ast_helper - open Location + type label = string - module String = Misc.Stdlib.String + type arg_label (*IF_CURRENT = Asttypes.arg_label *) = + Nolabel + | Labelled of string (* label:T -> ... *) + | Optional of string (* ?label:T -> ... *) - type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> cases -> cases; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; + type 'a loc = 'a Location.loc = { + txt : 'a; + loc : Location.t; } - let map_fst f (x, y) = (f x, y) - let map_snd f (x, y) = (x, f y) - let map_tuple f1 f2 (x, y) = (f1 x, f2 y) - let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) - let map_opt f = function None -> None | Some x -> Some (f x) - - let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - - module T = struct - (* Type expressions for the core language *) - - let row_field sub { - prf_desc; - prf_loc; - prf_attributes; - } = - let loc = sub.location sub prf_loc in - let attrs = sub.attributes sub prf_attributes in - let desc = match prf_desc with - | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - in - Rf.mk ~loc ~attrs desc - - let object_field sub { - pof_desc; - pof_loc; - pof_attributes; - } = - let loc = sub.location sub pof_loc in - let attrs = sub.attributes sub pof_attributes in - let desc = match pof_desc with - | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t) - | Oinherit t -> Oinherit (sub.typ sub t) - in - Of.mk ~loc ~attrs desc - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs; ptyp_loc_stack = _ } = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs - (List.map (map_loc sub) sl) (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - let loc = sub.location sub ptype_loc in - let attrs = sub.attributes sub ptype_attributes in - Type.mk ~loc ~attrs (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_loc; - ptyext_attributes} = - let loc = sub.location sub ptyext_loc in - let attrs = sub.attributes sub ptyext_attributes in - Te.mk ~loc ~attrs - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - - let map_type_exception sub - {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = - let loc = sub.location sub ptyexn_loc in - let attrs = sub.attributes sub ptyexn_attributes in - Te.mk_exception ~loc ~attrs - (sub.extension_constructor sub ptyexn_constructor) - - let map_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - let loc = sub.location sub pext_loc in - let attrs = sub.attributes sub pext_attributes in - Te.constructor ~loc ~attrs - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - - end - - module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (o, ct) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) - end - - module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (s, mt1, mt2) -> - functor_ ~loc ~attrs (map_loc sub s) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) mt1) - (sub.module_type sub mt2) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> - type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typesubst l -> - type_subst ~loc (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) - end - - - module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (arg, arg_ty, body) -> - functor_ ~loc ~attrs (map_loc sub arg) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) arg_ty) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - let attrs = sub.attributes sub attrs in - eval ~loc ~attrs (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_declaration sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) - end - - module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs; pexp_loc_stack = _ } = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs x - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> - send ~loc ~attrs (sub.expr sub e) (map_loc sub s) - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (o, e) -> - open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e) - | Pexp_letop {let_; ands; body} -> - letop ~loc ~attrs (sub.binding_op sub let_) - (List.map (sub.binding_op sub) ands) (sub.expr sub body) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () - - let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = - let open Exp in - let op = map_loc sub pbop_op in - let pat = sub.pat sub pbop_pat in - let exp = sub.expr sub pbop_exp in - let loc = sub.location sub pbop_loc in - binding_op op pat exp loc - - end - - module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs; ppat_loc_stack = _ } = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs c - | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) - end - - module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (o, ce) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> - inherit_ ~loc ~attrs o (sub.class_expr sub ce) - (map_opt (map_loc sub) s) - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - let loc = sub.location sub pci_loc in - let attrs = sub.attributes sub pci_attributes in - Ci.mk ~loc ~attrs - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) - end - - (* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - - let default_mapper = - { - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - type_exception = T.map_type_exception; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - binding_op = E.map_binding_op; - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_substitution = - (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> - Ms.mk - (map_loc this pms_name) - (map_loc this pms_manifest) - ~attrs:(this.attributes this pms_attributes) - ~loc:(this.location this pms_loc) - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_declaration = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (this.module_expr this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - open_description = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this a -> - { - attr_name = map_loc this a.attr_name; - attr_payload = this.payload this a.attr_payload; - attr_loc = this.location this a.attr_loc - } - ); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - - let extension_of_error (error : Locations.location_error) : extension = - Locations.extension_of_error - ~mk_pstr:(fun x -> PStr x) - ~mk_extension:(fun x -> Str.extension x) - ~mk_string_constant:(fun x -> Str.eval (Exp.constant (Pconst_string (x, None)))) - error - - let attribute_of_warning loc s = - Attr.mk - {loc; txt = "ocaml.ppwarning" } - (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, None)))])) - - include Locations.Helpers_impl - - let cookies = ref String.Map.empty - - let get_cookie k = - try Some (String.Map.find k !cookies) - with Not_found -> None - - let set_cookie k v = - cookies := String.Map.add k v !cookies - - let tool_name_ref = ref "_none_" - - let tool_name () = !tool_name_ref - - - module PpxContext = struct - open Longident - open Asttypes - open Ast_helper - - let lid name = { txt = Lident name; loc = Location.none } - - let make_string x = Exp.constant (Pconst_string (x, None)) - - let make_bool x = - if x - then Exp.construct (lid "true") None - else Exp.construct (lid "false") None - - let rec make_list f lst = - match lst with - | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) - | [] -> - Exp.construct (lid "[]") None - - let make_pair f1 f2 (x1, x2) = - Exp.tuple [f1 x1; f2 x2] - - let make_option f opt = - match opt with - | Some x -> Exp.construct (lid "Some") (Some (f x)) - | None -> Exp.construct (lid "None") None - - let get_cookies () = - lid "cookies", - make_list (make_pair make_string (fun x -> x)) - (String.Map.bindings !cookies) - - let mk fields = - { - attr_name = { txt = "ocaml.ppx.context"; loc = Location.none }; - attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)]; - attr_loc = Location.none - } - - let make ~tool_name () = - let fields = - [ - lid "tool_name", make_string tool_name; - lid "include_dirs", make_list make_string !Clflags.include_dirs; - lid "load_path", make_list make_string (Migrate_parsetree_compiler_functions.get_load_paths ()); - lid "open_modules", make_list make_string !Clflags.open_modules; - lid "for_package", make_option make_string !Clflags.for_package; - lid "debug", make_bool !Clflags.debug; - lid "use_threads", make_bool !Clflags.use_threads; - lid "recursive_types", make_bool !Clflags.recursive_types; - lid "principal", make_bool !Clflags.principal; - lid "transparent_modules", make_bool !Clflags.transparent_modules; - lid "unboxed_types", make_bool (Migrate_parsetree_compiler_functions.get_unboxed_types ()); - get_cookies () - ] - in - mk fields - - let get_fields = function - | PStr [{pstr_desc = Pstr_eval - ({ pexp_desc = Pexp_record (fields, None); _ }, []); _}] -> - fields - | _ -> - raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" - - let restore fields = - let field name payload = - let rec get_string = function - | { pexp_desc = Pexp_constant (Pconst_string (str, None)); _ } -> str - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] string syntax" name - and get_bool pexp = - match pexp with - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"; _}, - None); _} -> - true - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"; _}, - None); _} -> - false - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] bool syntax" name - and get_list elem = function - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "::"; _}, - Some {pexp_desc = Pexp_tuple [exp; rest]; _}); _ } -> - elem exp :: get_list elem rest - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"; _}, None); _ } -> - [] - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] list syntax" name - and get_pair f1 f2 = function - | {pexp_desc = Pexp_tuple [e1; e2]; _} -> - (f1 e1, f2 e2) - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] pair syntax" name - and get_option elem = function - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "Some"; _ }, Some exp); _ } -> - Some (elem exp) - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "None"; _ }, None); _ } -> - None - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] option syntax" name - in - match name with - | "tool_name" -> - tool_name_ref := get_string payload - | "include_dirs" -> - Clflags.include_dirs := get_list get_string payload - | "load_path" -> - Migrate_parsetree_compiler_functions.load_path_init (get_list get_string payload) - | "open_modules" -> - Clflags.open_modules := get_list get_string payload - | "for_package" -> - Clflags.for_package := get_option get_string payload - | "debug" -> - Clflags.debug := get_bool payload - | "use_threads" -> - Clflags.use_threads := get_bool payload - | "recursive_types" -> - Clflags.recursive_types := get_bool payload - | "principal" -> - Clflags.principal := get_bool payload - | "transparent_modules" -> - Clflags.transparent_modules := get_bool payload - | "unboxed_types" -> - Migrate_parsetree_compiler_functions.set_unboxed_types (get_bool payload) - | "cookies" -> - let l = get_list (get_pair get_string (fun x -> x)) payload in - cookies := - List.fold_left - (fun s (k, v) -> String.Map.add k v s) String.Map.empty - l - | _ -> - () - in - List.iter (function ({txt=Lident name; _}, x) -> field name x | _ -> ()) fields - - let update_cookies fields = - let fields = - List.filter - (function ({txt=Lident "cookies"; _}, _) -> false | _ -> true) - fields - in - fields @ [get_cookies ()] - end - - let ppx_context = PpxContext.make - - let extension_of_exn exn = extension_of_error (Locations.location_error_of_exn exn) - - let apply_lazy ~source ~target mapper = - let implem ast = - let fields, ast = - match ast with - | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"; _}; - attr_payload = x; _}); _} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.structure mapper ast - with exn -> - [{pstr_desc = Pstr_extension (extension_of_exn exn, []); - pstr_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Str.attribute (PpxContext.mk fields) :: ast - in - let iface ast = - let fields, ast = - match ast with - | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"; _}; - attr_payload = x; - attr_loc = _}); _} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.signature mapper ast - with exn -> - [{psig_desc = Psig_extension (extension_of_exn exn, []); - psig_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Sig.attribute (PpxContext.mk fields) :: ast - in - - let ic = open_in_bin source in - let magic = - really_input_string ic (String.length Config.ast_impl_magic_number) - in - - let rewrite transform = - Location.input_name := input_value ic; - let ast = input_value ic in - close_in ic; - let ast = transform ast in - let oc = open_out_bin target in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc - and fail () = - close_in ic; - failwith "Ast_mapper: OCaml version mismatch or malformed input"; - in - - if magic = Config.ast_impl_magic_number then - rewrite (implem : structure -> structure) - else if magic = Config.ast_intf_magic_number then - rewrite (iface : signature -> signature) - else fail () - - let drop_ppx_context_str ~restore = function - | {pstr_desc = Pstr_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"; _}; - attr_payload = a; - attr_loc = _}; _ } - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - - let drop_ppx_context_sig ~restore = function - | {psig_desc = Psig_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"; _}; - attr_payload = a; - attr_loc = _}; _ } - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - - let add_ppx_context_str ~tool_name ast = - Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast - - let add_ppx_context_sig ~tool_name ast = - Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast - - - let apply ~source ~target mapper = - apply_lazy ~source ~target (fun () -> mapper) - - let run_main mapper = - try - let a = Sys.argv in - let n = Array.length a in - if n > 2 then - let mapper () = - try mapper (Array.to_list (Array.sub a 1 (n - 3))) - with exn -> - (* PR#6463 *) - let f _ _ = raise exn in - {default_mapper with structure = f; signature = f} - in - apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper - else begin - Printf.eprintf "Usage: %s [extra_args] \n%!" - Sys.executable_name; - exit 2 - end - with exn -> - prerr_endline (Printexc.to_string exn); - exit 2 + type variance (*IF_CURRENT = Asttypes.variance *) = + | Covariant + | Contravariant + | Invariant - let register_function = ref (fun _name f -> run_main f) - let register name f = !register_function name f end module Outcometree = struct @@ -4037,117 +213,3 @@ module Outcometree = struct | Ophr_exception of (exn * out_value) end -module Config = struct - let ast_impl_magic_number = "Caml1999M025" - let ast_intf_magic_number = "Caml1999N025" -end - -let map_signature mapper = mapper.Ast_mapper.signature mapper -let map_structure mapper = mapper.Ast_mapper.structure mapper - -let shallow_identity = - let id _ x = x in - { - Ast_mapper. - structure = id; - structure_item = id; - module_expr = id; - signature = id; - signature_item = id; - module_type = id; - with_constraint = id; - class_declaration = id; - class_expr = id; - class_field = id; - class_structure = id; - class_type = id; - class_type_field = id; - class_signature = id; - class_type_declaration = id; - class_description = id; - type_declaration = id; - type_kind = id; - typ = id; - type_extension = id; - extension_constructor = id; - value_description = id; - pat = id; - expr = id; - module_declaration = id; - module_type_declaration = id; - module_binding = id; - open_description = id; - include_description = id; - include_declaration = id; - value_binding = id; - constructor_declaration = id; - label_declaration = id; - cases = id; - case = id; - location = id; - extension = id; - attribute = id; - attributes = id; - payload = id; - binding_op = id; - module_substitution = id; - open_declaration = id; - type_exception = id; - } - -let failing_mapper = - let fail _ _ = - invalid_arg "failing_mapper: this mapper function should never get called" - in - { - Ast_mapper. - structure = fail; - structure_item = fail; - module_expr = fail; - signature = fail; - signature_item = fail; - module_type = fail; - with_constraint = fail; - class_declaration = fail; - class_expr = fail; - class_field = fail; - class_structure = fail; - class_type = fail; - class_type_field = fail; - class_signature = fail; - class_type_declaration = fail; - class_description = fail; - type_declaration = fail; - type_kind = fail; - typ = fail; - type_extension = fail; - extension_constructor = fail; - value_description = fail; - pat = fail; - expr = fail; - module_declaration = fail; - module_type_declaration = fail; - module_binding = fail; - open_description = fail; - include_description = fail; - include_declaration = fail; - value_binding = fail; - constructor_declaration = fail; - label_declaration = fail; - cases = fail; - case = fail; - location = fail; - extension = fail; - attribute = fail; - attributes = fail; - payload = fail; - binding_op = fail; - module_substitution = fail; - open_declaration = fail; - type_exception = fail; - } - -let make_top_mapper ~signature ~structure = - {failing_mapper with Ast_mapper. - signature = (fun _ x -> signature x); - structure = (fun _ x -> structure x) } diff --git a/src/vendored-omp/src/ast_409.ml b/src/vendored-omp/src/ast_409.ml index ab43e0d97..e60576b3d 100644 --- a/src/vendored-omp/src/ast_409.ml +++ b/src/vendored-omp/src/ast_409.ml @@ -17,3877 +17,53 @@ (* *) (**************************************************************************) -open Stdlib0 -open Ast_409_helper - -module Location = Location -module Longident = Longident - -module Asttypes = struct - - type constant (*IF_CURRENT = Asttypes.constant *) = - Const_int of int - | Const_char of char - | Const_string of string * string option - | Const_float of string - | Const_int32 of int32 - | Const_int64 of int64 - | Const_nativeint of nativeint - - type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive - - type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto - - (* Order matters, used in polymorphic comparison *) - type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - - type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - - type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - - type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh - - type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open - - type label = string - - type arg_label (*IF_CURRENT = Asttypes.arg_label *) = - Nolabel - | Labelled of string (* label:T -> ... *) - | Optional of string (* ?label:T -> ... *) - - type 'a loc = 'a Location.loc = { - txt : 'a; - loc : Location.t; - } - - - type variance (*IF_CURRENT = Asttypes.variance *) = - | Covariant - | Contravariant - | Invariant - -end - -module Parsetree = struct - - open Asttypes - - type constant (*IF_CURRENT = Parsetree.constant *) = - Pconst_integer of string * char option - (* 3 3l 3L 3n - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker - *) - | Pconst_char of char - (* 'c' *) - | Pconst_string of string * string option - (* "constant" - {delim|other constant|delim} - *) - | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - - (** {1 Extension points} *) - - type attribute (*IF_CURRENT = Parsetree.attribute *) = { - attr_name : string loc; - attr_payload : payload; - attr_loc : Location.t; - } - (* [@id ARG] - [@@id ARG] - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - - and extension = string loc * payload - (* [%id ARG] - [%%id ARG] - - Sub-language placeholder -- rejected by the typechecker. - *) - - and attributes = attribute list - - and payload (*IF_CURRENT = Parsetree.payload *) = - | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - - (** {1 Core language} *) - - (* Type expressions *) - - and core_type (*IF_CURRENT = Parsetree.core_type *) = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_loc_stack: Location.t list; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and typ = core_type - - and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional - *) - | Ptyp_tuple of core_type list - (* T1 * ... * Tn - - Invariant: n >= 2 - *) - | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of object_field list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). - - - As the core_type of a Pctf_method node. - - - As the core_type of a Pexp_poly node. - - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) - - and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) - - and row_field (*IF_CURRENT = Parsetree.row_field *) = { - prf_desc : row_field_desc; - prf_loc : Location.t; - prf_attributes : attributes; - } - - and row_field_desc (*IF_CURRENT = Parsetree.row_field_desc *) = - | Rtag of label loc * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 'bool' field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - *) - | Rinherit of core_type - (* [ T ] *) - - and object_field (*IF_CURRENT = Parsetree.object_field *) = { - pof_desc : object_field_desc; - pof_loc : Location.t; - pof_attributes : attributes; - } - - and object_field_desc (*IF_CURRENT = Parsetree.object_field_desc *) = - | Otag of label loc * core_type - | Oinherit of core_type - - (* Patterns *) - - and pattern (*IF_CURRENT = Parsetree.pattern *) = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_loc_stack: Location.t list; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and pat = pattern - - and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Ppat_interval of constant * constant - (* 'a'..'z' - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (* (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Ppat_construct of Longident.t loc * pattern option - (* C None - C P Some P - C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) - *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) - | Ppat_unpack of string loc - (* (module P) - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of Longident.t loc * pattern - (* M.(P) *) - - (* Value expressions *) - - and expression (*IF_CURRENT = Parsetree.expression *) = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_loc_stack: Location.t list; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and expr = expression - - and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = - | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of cases - (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) - | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pexp_match of expression * cases - (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * cases - (* try E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_tuple of expression list - (* (E1, ..., En) - - Invariant: n >= 2 - *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) - | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) - | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * label loc - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of label loc * expression - (* x <- 2 *) - | Pexp_override of (label loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) - | Pexp_letmodule of string loc * module_expr * expression - (* let module M = ME in E *) - | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) - | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) - | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string loc * expression - (* fun (type t) -> E *) - | Pexp_pack of module_expr - (* (module ME) - - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of open_declaration * expression - (* M.(E) - let open M in E - let! open M in E *) - | Pexp_letop of letop - (* let* P = E in E - let* P = E and* P = E in E *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable - (* . *) - - and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - - and cases = case list - - and letop (*IF_CURRENT = Parsetree.letop *) = - { - let_ : binding_op; - ands : binding_op list; - body : expression; - } - - and binding_op (*IF_CURRENT = Parsetree.binding_op *) = - { - pbop_op : string loc; - pbop_pat : pattern; - pbop_exp : expression; - pbop_loc : Location.t; - } - - (* Value descriptions *) - - and value_description (*IF_CURRENT = Parsetree.value_description *) = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } - -(* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) - *) - - (* Type declarations *) - - and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = - { - ptype_name: string loc; - ptype_params: (core_type * variance) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } - -(* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) - *) - - and type_kind (*IF_CURRENT = Parsetree.type_kind *) = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) - | Ptype_open - - and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l : T [@id1] [@id2] *) - } - - (* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. - *) - - and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = - { - pcd_name: string loc; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - -(* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) - *) - - and type_extension (*IF_CURRENT = Parsetree.type_extension *) = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * variance) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_loc: Location.t; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } -(* - type t += ... - *) - - and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - (* exception E *) - and type_exception (*IF_CURRENT = Parsetree.type_exception *) = - { - ptyexn_constructor: extension_constructor; - ptyexn_loc: Location.t; - ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = - Pext_decl of constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([T1; ...; Tn], None) - | C: T0 ([], Some T0) - | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) - *) - | Pext_rebind of Longident.t loc - (* - | C = D - *) - - (** {1 Class language} *) - - (* Type expressions for the class language *) - - and class_type (*IF_CURRENT = Parsetree.class_type *) = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = - | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) - | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - | Pcty_open of open_description * class_type - (* let open M in CT *) - - and class_signature (*IF_CURRENT = Parsetree.class_signature *) = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } - (* object('selfpat) ... end - object ... end (self = Ptyp_any) - *) - - and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = - | Pctf_inherit of class_type - (* inherit CT *) - | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) - - and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = - { - pci_virt: virtual_flag; - pci_params: (core_type * variance) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... - - Also used for "class type" declaration. - *) - - and class_description = class_type class_infos - - and class_type_declaration = class_type class_infos - - (* Value expressions for the class language *) - - and class_expr (*IF_CURRENT = Parsetree.class_expr *) = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = - | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - | Pcl_open of open_description * class_expr - (* let open M in CE *) - - - and class_structure (*IF_CURRENT = Parsetree.class_structure *) = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } - (* object(selfpat) ... end - object ... end (self = Ppat_any) - *) - - and class_field (*IF_CURRENT = Parsetree.class_field *) = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_field_desc (*IF_CURRENT = Parsetree.class_field_desc *) = - | Pcf_inherit of override_flag * class_expr * string loc option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) - | Pcf_val of (label loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) - | Pcf_method of (label loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) - - and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - - and class_declaration = class_expr class_infos - - (** {1 Module language} *) - - (* Type expressions for the module language *) - - and module_type (*IF_CURRENT = Parsetree.module_type *) = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) - | Pmty_functor of string loc * module_type option * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) - - and signature = signature_item list - - and signature_item (*IF_CURRENT = Parsetree.signature_item *) = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - - and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = - | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) - | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typesubst of type_declaration list - (* type t1 := ... and ... and tn := ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of type_exception - (* exception C of T *) - | Psig_module of module_declaration - (* module X = M - module X : MT *) - | Psig_modsubst of module_substitution - (* module X := M *) - | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) - | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) - | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) - - and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = - { - pmd_name: string loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } - (* S : MT *) - - and module_substitution (*IF_CURRENT = Parsetree.module_substitution *) = - { - pms_name: string loc; - pms_manifest: Longident.t loc; - pms_attributes: attributes; (* ... [@@id1] [@@id2] *) - pms_loc: Location.t; - } - - and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } - (* S = MT - S (abstract module type declaration, pmtd_type = None) - *) - - and 'a open_infos (*IF_CURRENT = 'a Parsetree.open_infos *) = - { - popen_expr: 'a; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } - (* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) - - and open_description = Longident.t loc open_infos - (* open M.N - open M(N).O *) - - and open_declaration = module_expr open_infos - (* open M.N - open M(N).O - open struct ... end *) - - and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - - and include_description = module_type include_infos - (* include MT *) - - and include_declaration = module_expr include_infos - (* include ME *) - - and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = - | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) - | Pwith_typesubst of Longident.t loc * type_declaration - (* with type X.t := ..., same format as [Pwith_type] *) - | Pwith_modsubst of Longident.t loc * Longident.t loc - (* with module X.Y := Z *) - - (* Value expressions for the module language *) - - and module_expr (*IF_CURRENT = Parsetree.module_expr *) = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) - | Pmod_functor of string loc * module_type option * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) - - and structure = structure_item list - - and structure_item (*IF_CURRENT = Parsetree.structure_item *) = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - - and structure_item_desc (*IF_CURRENT = Parsetree.structure_item_desc *) = - | Pstr_eval of expression * attributes - (* E *) - | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) - | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) - | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) - | Pstr_exception of type_exception - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) - | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_declaration - (* open X *) - | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) - | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) - - and value_binding (*IF_CURRENT = Parsetree.value_binding *) = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - - and module_binding (*IF_CURRENT = Parsetree.module_binding *) = - { - pmb_name: string loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } - (* X = ME *) - - (** {1 Toplevel} *) - - (* Toplevel phrases *) - - type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = - | Ptop_def of structure - | Ptop_dir of toplevel_directive - (* #use, #load ... *) - - and toplevel_directive (*IF_CURRENT = Parsetree.toplevel_directive *) = - { - pdir_name : string loc; - pdir_arg : directive_argument option; - pdir_loc : Location.t; - } - - and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = - { - pdira_desc : directive_argument_desc; - pdira_loc : Location.t; - } - - and directive_argument_desc (*IF_CURRENT = Parsetree.directive_argument_desc *) = - | Pdir_string of string - | Pdir_int of string * char option - | Pdir_ident of Longident.t - | Pdir_bool of bool - -end - -module Docstrings : sig - (** (Re)Initialise all docstring state *) - val init : unit -> unit - - (** Emit warnings for unattached and ambiguous docstrings *) - val warn_bad_docstrings : unit -> unit - - (** {2 Docstrings} *) - - (** Documentation comments *) - type docstring - - (** Create a docstring *) - val docstring : string -> Location.t -> docstring - - (** Register a docstring *) - val register : docstring -> unit - - (** Get the text of a docstring *) - val docstring_body : docstring -> string - - (** Get the location of a docstring *) - val docstring_loc : docstring -> Location.t - - (** {2 Set functions} - - These functions are used by the lexer to associate docstrings to - the locations of tokens. *) - - (** Docstrings immediately preceding a token *) - val set_pre_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately following a token *) - val set_post_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings not immediately adjacent to a token *) - val set_floating_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately following the token which precedes this one *) - val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately preceding the token which follows this one *) - val set_post_extra_docstrings : Lexing.position -> docstring list -> unit - - (** {2 Items} - - The {!docs} type represents documentation attached to an item. *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - val empty_docs : docs - - val docs_attr : docstring -> Parsetree.attribute - - (** Convert item documentation to attributes and add them to an - attribute list *) - val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) - val symbol_docs : unit -> docs - val symbol_docs_lazy : unit -> docs Lazy.t - - (** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) - val rhs_docs : int -> int -> docs - val rhs_docs_lazy : int -> int -> docs Lazy.t - - (** Mark the item documentation for the current symbol (for ambiguity - warnings). *) - val mark_symbol_docs : unit -> unit - - (** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) - val mark_rhs_docs : int -> int -> unit - - (** {2 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - - type info = docstring option - - val empty_info : info - - val info_attr : docstring -> Parsetree.attribute - - (** Convert field info to attributes and add them to an - attribute list *) - val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the field info for the current symbol. *) - val symbol_info : unit -> info - - (** Fetch the field info following the symbol at a given position. *) - val rhs_info : int -> info - - (** {2 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - - type text = docstring list - - val empty_text : text - val empty_text_lazy : text Lazy.t - - val text_attr : docstring -> Parsetree.attribute - - (** Convert text to attributes and add them to an attribute list *) - val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the text preceding the current symbol. *) - val symbol_text : unit -> text - val symbol_text_lazy : unit -> text Lazy.t - - (** Fetch the text preceding the symbol at the given position. *) - val rhs_text : int -> text - val rhs_text_lazy : int -> text Lazy.t - - (** {2 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - - (** Fetch additional text preceding the current symbol *) - val symbol_pre_extra_text : unit -> text - - (** Fetch additional text following the current symbol *) - val symbol_post_extra_text : unit -> text - - (** Fetch additional text preceding the symbol at the given position *) - val rhs_pre_extra_text : int -> text - - (** Fetch additional text following the symbol at the given position *) - val rhs_post_extra_text : int -> text - - (** Fetch text following the symbol at the given position *) - val rhs_post_text : int -> text - - module WithMenhir: sig - (** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) - val symbol_docs : Lexing.position * Lexing.position -> docs - val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t - - (** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) - val rhs_docs : Lexing.position -> Lexing.position -> docs - val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t - - (** Mark the item documentation for the current symbol (for ambiguity - warnings). *) - val mark_symbol_docs : Lexing.position * Lexing.position -> unit - - (** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) - val mark_rhs_docs : Lexing.position -> Lexing.position -> unit - - (** Fetch the field info for the current symbol. *) - val symbol_info : Lexing.position -> info - - (** Fetch the field info following the symbol at a given position. *) - val rhs_info : Lexing.position -> info - - (** Fetch the text preceding the current symbol. *) - val symbol_text : Lexing.position -> text - val symbol_text_lazy : Lexing.position -> text Lazy.t - - (** Fetch the text preceding the symbol at the given position. *) - val rhs_text : Lexing.position -> text - val rhs_text_lazy : Lexing.position -> text Lazy.t - - (** {3 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - - (** Fetch additional text preceding the current symbol *) - val symbol_pre_extra_text : Lexing.position -> text - - (** Fetch additional text following the current symbol *) - val symbol_post_extra_text : Lexing.position -> text - - (** Fetch additional text preceding the symbol at the given position *) - val rhs_pre_extra_text : Lexing.position -> text - - (** Fetch additional text following the symbol at the given position *) - val rhs_post_extra_text : Lexing.position -> text - - (** Fetch text following the symbol at the given position *) - val rhs_post_text : Lexing.position -> text - - end -end = struct - open Location - - (* Docstrings *) - - (* A docstring is "attached" if it has been inserted in the AST. This - is used for generating unexpected docstring warnings. *) - type ds_attached = - | Unattached (* Not yet attached anything.*) - | Info (* Attached to a field or constructor. *) - | Docs (* Attached to an item or as floating text. *) - - (* A docstring is "associated" with an item if there are no blank lines between - them. This is used for generating docstring ambiguity warnings. *) - type ds_associated = - | Zero (* Not associated with an item *) - | One (* Associated with one item *) - | Many (* Associated with multiple items (ambiguity) *) - - type docstring = - { ds_body: string; - ds_loc: Location.t; - mutable ds_attached: ds_attached; - mutable ds_associated: ds_associated; } - - (* List of docstrings *) - - let docstrings : docstring list ref = ref [] - - (* Warn for unused and ambiguous docstrings *) - - let warn_bad_docstrings () = - if Warnings.is_active (Migrate_parsetree_compiler_functions.bad_docstring true) then begin - List.iter - (fun ds -> - match ds.ds_attached with - | Info -> () - | Unattached -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring true) - | Docs -> - match ds.ds_associated with - | Zero | One -> () - | Many -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring false)) - (List.rev !docstrings) - end - - (* Docstring constructors and destructors *) - - let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; - ds_attached = Unattached; - ds_associated = Zero; } - in - ds - - let register ds = - docstrings := ds :: !docstrings - - let docstring_body ds = ds.ds_body - - let docstring_loc ds = ds.ds_loc - - (* Docstrings attached to items *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - let empty_docs = { docs_pre = None; docs_post = None } - - let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - - let docs_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - { attr_name = doc_loc; - attr_payload = PStr [item]; - attr_loc = Location.none } - - let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - - (* Docstrings attached to constructors or fields *) - - type info = docstring option - - let empty_info = None - - let info_attr = docs_attr - - let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - - (* Docstrings not attached to a specific item *) - - type text = docstring list - - let empty_text = [] - let empty_text_lazy = lazy [] - - let text_loc = {txt = "ocaml.text"; loc = Location.none} - - let text_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - { attr_name = text_loc; - attr_payload = PStr [item]; - attr_loc = Location.none } - - let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""; _} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - - (* Find the first non-info docstring in a list, attach it and return it *) - let get_docstring ~info dsl = - let rec loop = function - | [] -> None - | {ds_attached = Info; _} :: rest -> loop rest - | ds :: _ -> - ds.ds_attached <- if info then Info else Docs; - Some ds - in - loop dsl - - (* Find all the non-info docstrings in a list, attach them and return them *) - let get_docstrings dsl = - let rec loop acc = function - | [] -> List.rev acc - | {ds_attached = Info; _} :: rest -> loop acc rest - | ds :: rest -> - ds.ds_attached <- Docs; - loop (ds :: acc) rest - in - loop [] dsl - - (* "Associate" all the docstrings in a list *) - let associate_docstrings dsl = - List.iter - (fun ds -> - match ds.ds_associated with - | Zero -> ds.ds_associated <- One - | (One | Many) -> ds.ds_associated <- Many) - dsl - - (* Map from positions to pre docstrings *) - - let pre_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_pre_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_table pos dsl - - let get_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - - let mark_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl - with Not_found -> () - - (* Map from positions to post docstrings *) - - let post_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_post_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_table pos dsl - - let get_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - - let mark_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl - with Not_found -> () - - let get_info pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstring ~info:true dsl - with Not_found -> None - - (* Map from positions to floating docstrings *) - - let floating_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_floating_docstrings pos dsl = - if dsl <> [] then Hashtbl.add floating_table pos dsl - - let get_text pos = - try - let dsl = Hashtbl.find floating_table pos in - get_docstrings dsl - with Not_found -> [] - - let get_post_text pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstrings dsl - with Not_found -> [] - - (* Maps from positions to extra docstrings *) - - let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_pre_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_extra_table pos dsl - - let get_pre_extra_text pos = - try - let dsl = Hashtbl.find pre_extra_table pos in - get_docstrings dsl - with Not_found -> [] - - let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_post_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_extra_table pos dsl - - let get_post_extra_text pos = - try - let dsl = Hashtbl.find post_extra_table pos in - get_docstrings dsl - with Not_found -> [] - - (* Docstrings from parser actions *) - module WithParsing = struct - let symbol_docs () = - { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); - docs_post = get_post_docs (Parsing.symbol_end_pos ()); } - - let symbol_docs_lazy () = - let p1 = Parsing.symbol_start_pos () in - let p2 = Parsing.symbol_end_pos () in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); - docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } - - let rhs_docs_lazy pos1 pos2 = - let p1 = Parsing.rhs_start_pos pos1 in - let p2 = Parsing.rhs_end_pos pos2 in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let mark_symbol_docs () = - mark_pre_docs (Parsing.symbol_start_pos ()); - mark_post_docs (Parsing.symbol_end_pos ()) - - let mark_rhs_docs pos1 pos2 = - mark_pre_docs (Parsing.rhs_start_pos pos1); - mark_post_docs (Parsing.rhs_end_pos pos2) - - let symbol_info () = - get_info (Parsing.symbol_end_pos ()) - - let rhs_info pos = - get_info (Parsing.rhs_end_pos pos) - - let symbol_text () = - get_text (Parsing.symbol_start_pos ()) - - let symbol_text_lazy () = - let pos = Parsing.symbol_start_pos () in - lazy (get_text pos) - - let rhs_text pos = - get_text (Parsing.rhs_start_pos pos) - - let rhs_post_text pos = - get_post_text (Parsing.rhs_end_pos pos) - - let rhs_text_lazy pos = - let pos = Parsing.rhs_start_pos pos in - lazy (get_text pos) - - let symbol_pre_extra_text () = - get_pre_extra_text (Parsing.symbol_start_pos ()) - - let symbol_post_extra_text () = - get_post_extra_text (Parsing.symbol_end_pos ()) - - let rhs_pre_extra_text pos = - get_pre_extra_text (Parsing.rhs_start_pos pos) - - let rhs_post_extra_text pos = - get_post_extra_text (Parsing.rhs_end_pos pos) - end - - include WithParsing - - module WithMenhir = struct - let symbol_docs (startpos, endpos) = - { docs_pre = get_pre_docs startpos; - docs_post = get_post_docs endpos; } - - let symbol_docs_lazy (p1, p2) = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs pos1; - docs_post = get_post_docs pos2; } - - let rhs_docs_lazy p1 p2 = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let mark_symbol_docs (startpos, endpos) = - mark_pre_docs startpos; - mark_post_docs endpos; - () - - let mark_rhs_docs pos1 pos2 = - mark_pre_docs pos1; - mark_post_docs pos2; - () - - let symbol_info endpos = - get_info endpos - - let rhs_info endpos = - get_info endpos - - let symbol_text startpos = - get_text startpos - - let symbol_text_lazy startpos = - lazy (get_text startpos) - - let rhs_text pos = - get_text pos - - let rhs_post_text pos = - get_post_text pos - - let rhs_text_lazy pos = - lazy (get_text pos) - - let symbol_pre_extra_text startpos = - get_pre_extra_text startpos - - let symbol_post_extra_text endpos = - get_post_extra_text endpos - - let rhs_pre_extra_text pos = - get_pre_extra_text pos - - let rhs_post_extra_text pos = - get_post_extra_text pos - end - - (* (Re)Initialise all comment state *) - - let init () = - docstrings := []; - Hashtbl.reset pre_table; - Hashtbl.reset post_table; - Hashtbl.reset floating_table; - Hashtbl.reset pre_extra_table; - Hashtbl.reset post_extra_table -end - -module Ast_helper : sig - open Asttypes - open Docstrings - open Parsetree - - type 'a with_loc = 'a Location.loc - type loc = Location.t - - type lid = Longident.t with_loc - type str = string with_loc - type attrs = attribute list - - (** {1 Default locations} *) - - val default_loc: loc ref - (** Default value for all optional location arguments. *) - - val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - - (** {1 Constants} *) - - module Const : sig - val char : char -> constant - val string : ?quotation_delimiter:string -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant - end - - (** {1 Attributes} *) - module Attr : sig - val mk: ?loc:loc -> str -> payload -> attribute - end - - (** {1 Core language} *) - - (** Type expressions *) - module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - - (** Patterns *) - module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - - (** Expressions *) - module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> cases -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> cases - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> cases -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression - -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression - -> expression - val letop: ?loc:loc -> ?attrs:attrs -> binding_op - -> binding_op list -> expression -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - val binding_op: str -> pattern -> expression -> loc -> binding_op - end - - (** Value declarations *) - module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - - (** Type declarations *) - module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * variance) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - - (** Type extensions *) - module Te: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * variance) list -> ?priv:private_flag -> - lid -> extension_constructor list -> type_extension - - val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - extension_constructor -> type_exception - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - - (** {1 Module language} *) - - (** Module type expressions *) - module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - - (** Module expressions *) - module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - - (** Signature items *) - module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_subst: ?loc:loc -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> type_exception -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val mod_subst: ?loc:loc -> module_substitution -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - - (** Structure items *) - module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> type_exception -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_declaration -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - - (** Module declarations *) - module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_type -> module_declaration - end - - (** Module substitutions *) - module Ms: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> lid -> module_substitution - end - - (** Module type declarations *) - module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - - (** Module bindings *) - module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_expr -> module_binding - end - - (** Opens *) - module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> 'a -> 'a open_infos - end - - (** Includes *) - module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - - (** Value bindings *) - module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - - (** {1 Class language} *) - - (** Class type expressions *) - module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type - -> class_type - end - - (** Class type fields *) - module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - - (** Class expressions *) - module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr - -> class_expr - end - - (** Class fields *) - module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - - (** Classes *) - module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> ?params:(core_type * variance) list -> - str -> 'a -> 'a class_infos - end - - (** Class signatures *) - module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - - (** Class structures *) - module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - - (** Row fields *) - module Rf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> bool -> core_type list -> row_field - val inherit_: ?loc:loc -> core_type -> row_field - end - - (** Object fields *) - module Of: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - object_field_desc -> object_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> core_type -> object_field - val inherit_: ?loc:loc -> core_type -> object_field - end -end = struct - open Asttypes - open Parsetree - open Docstrings - - type 'a with_loc = 'a Location.loc - type loc = Location.t - - type lid = Longident.t with_loc - type str = string with_loc - type attrs = attribute list - - let default_loc = ref Location.none - - let with_default_loc l f = - Misc.protect_refs [Misc.R (default_loc, l)] f - - module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (Int.to_string i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) - end - - module Attr = struct - let mk ?(loc= !default_loc) name payload = - { attr_name = name; - attr_payload = payload; - attr_loc = loc } - end - - module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; - ptyp_loc = loc; - ptyp_loc_stack = []; - ptyp_attributes = attrs} - - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - - let varify_constructors var_names t = - let check_variable vl loc v = - if List.mem v vl then - raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in - let var_names = List.map (fun v -> v.txt) var_names in - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> - check_variable var_names t.ptyp_loc x; - Ptyp_var x - | Ptyp_arrow (label,core_type,core_type') -> - Ptyp_arrow(label, loop core_type, loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr( { txt = Longident.Lident s; _ }, []) - when List.mem s var_names -> - Ptyp_var s - | Ptyp_constr(longident, lst) -> - Ptyp_constr(longident, List.map loop lst) - | Ptyp_object (lst, o) -> - Ptyp_object (List.map loop_object_field lst, o) - | Ptyp_class (longident, lst) -> - Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) - in - {t with ptyp_desc = desc} - and loop_row_field field = - let prf_desc = match field.prf_desc with - | Rtag(label,flag,lst) -> - Rtag(label,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - in - { field with prf_desc; } - and loop_object_field field = - let pof_desc = match field.pof_desc with - | Otag(label, t) -> - Otag(label, loop t) - | Oinherit t -> - Oinherit (loop t) - in - { field with pof_desc; } - in - loop t - - end - - module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; - ppat_loc = loc; - ppat_loc_stack = []; - ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) - end - - module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b)) - let letop ?loc ?attrs let_ ands body = - mk ?loc ?attrs (Pexp_letop {let_; ands; body}) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - - let binding_op op pat exp loc = - { - pbop_op = op; - pbop_pat = pat; - pbop_exp = exp; - pbop_loc = loc; - } - end - - module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) - end - - module Mod = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg arg_ty body = - mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) - end - - module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_subst ?loc a = mk ?loc (Psig_typesubst a) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let mod_subst ?loc a = mk ?loc (Psig_modsubst a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b)) - end - - module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b)) - end - - module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - - end - - module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - - end - - module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } - end - - module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } - end - - module Ms = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name syn = - { - pms_name = name; - pms_manifest = syn; - pms_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pms_loc = loc; - } - end - - module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } - end - - module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } - end - - module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) expr = - { - popen_expr = expr; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } - end - - module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - - end - - module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } - end - - module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } - end - - module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - - end - - (** Type extensions *) - module Te = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_loc = loc; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - constructor = - { - ptyexn_constructor = constructor; - ptyexn_loc = loc; - ptyexn_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - end - - module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } - end - - module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } - end - - (** Row fields *) - module Rf = struct - let mk ?(loc = !default_loc) ?(attrs = []) desc = { - prf_desc = desc; - prf_loc = loc; - prf_attributes = attrs; - } - let tag ?loc ?attrs label const tys = - mk ?loc ?attrs (Rtag (label, const, tys)) - let inherit_?loc ty = - mk ?loc (Rinherit ty) - end - - (** Object fields *) - module Of = struct - let mk ?(loc = !default_loc) ?(attrs=[]) desc = { - pof_desc = desc; - pof_loc = loc; - pof_attributes = attrs; - } - let tag ?loc ?attrs label ty = - mk ?loc ?attrs (Otag (label, ty)) - let inherit_ ?loc ty = - mk ?loc (Oinherit ty) - end -end - -module Ast_mapper : sig - open Parsetree - - (** {1 A generic Parsetree mapper} *) - - type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> cases -> cases; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - (** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - - val default_mapper: mapper - (** A default mapper, which implements a "deep identity" mapping. *) - - (** {1 Apply mappers to compilation units} *) - - val tool_name: unit -> string - (** Can be used within a ppx preprocessor to know which tool is - calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], - ["ocaml"], ... Some global variables that reflect command-line - options are automatically synchronized between the calling tool - and the ppx preprocessor: {!Clflags.include_dirs}, - {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package}, - {!Clflags.debug}. *) - - - val apply: source:string -> target:string -> mapper -> unit - (** Apply a mapper (parametrized by the unit name) to a dumped - parsetree found in the [source] file and put the result in the - [target] file. The [structure] or [signature] field of the mapper - is applied to the implementation or interface. *) - - val run_main: (string list -> mapper) -> unit - (** Entry point to call to implement a standalone -ppx rewriter from a - mapper, parametrized by the command line arguments. The current - unit name can be obtained from {!Location.input_name}. This - function implements proper error reporting for uncaught - exceptions. *) - - (** {1 Registration API} *) - - val register_function: (string -> (string list -> mapper) -> unit) ref - - val register: string -> (string list -> mapper) -> unit - (** Apply the [register_function]. The default behavior is to run the - mapper immediately, taking arguments from the process command - line. This is to support a scenario where a mapper is linked as a - stand-alone executable. - - It is possible to overwrite the [register_function] to define - "-ppx drivers", which combine several mappers in a single process. - Typically, a driver starts by defining [register_function] to a - custom implementation, then lets ppx rewriters (linked statically - or dynamically) register themselves, and then run all or some of - them. It is also possible to have -ppx drivers apply rewriters to - only specific parts of an AST. - - The first argument to [register] is a symbolic name to be used by - the ppx driver. *) - - - (** {1 Convenience functions to write mappers} *) - - val map_opt: ('a -> 'b) -> 'a option -> 'b option - - val extension_of_error: Locations.location_error -> extension - (** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) +module Location = Location +module Longident = Longident - val attribute_of_warning: Location.t -> string -> attribute - (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) +module Asttypes = struct - include Locations.Helpers_intf + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * string option + | Const_float of string + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint - (** {1 Helper functions to call external mappers} *) + type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive - val add_ppx_context_str: - tool_name:string -> Parsetree.structure -> Parsetree.structure - (** Extract information from the current environment and encode it - into an attribute which is prepended to the list of structure - items in order to pass the information to an external - processor. *) + type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto - val add_ppx_context_sig: - tool_name:string -> Parsetree.signature -> Parsetree.signature - (** Same as [add_ppx_context_str], but for signatures. *) + (* Order matters, used in polymorphic comparison *) + type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - val drop_ppx_context_str: - restore:bool -> Parsetree.structure -> Parsetree.structure - (** Drop the ocaml.ppx.context attribute from a structure. If - [restore] is true, also restore the associated data in the current - process. *) + type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - val drop_ppx_context_sig: - restore:bool -> Parsetree.signature -> Parsetree.signature - (** Same as [drop_ppx_context_str], but for signatures. *) + type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - (** {1 Cookies} *) + type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh - (** Cookies are used to pass information from a ppx processor to - a further invocation of itself, when called from the OCaml - toplevel (or other tools that support cookies). *) + type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open - val set_cookie: string -> Parsetree.expression -> unit - val get_cookie: string -> Parsetree.expression option -end = struct - open Parsetree - open Ast_helper - open Location + type label = string - module String = Misc.Stdlib.String + type arg_label (*IF_CURRENT = Asttypes.arg_label *) = + Nolabel + | Labelled of string (* label:T -> ... *) + | Optional of string (* ?label:T -> ... *) - type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> cases -> cases; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; + type 'a loc = 'a Location.loc = { + txt : 'a; + loc : Location.t; } - let map_fst f (x, y) = (f x, y) - let map_snd f (x, y) = (x, f y) - let map_tuple f1 f2 (x, y) = (f1 x, f2 y) - let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) - let map_opt f = function None -> None | Some x -> Some (f x) - - let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - - module T = struct - (* Type expressions for the core language *) - - let row_field sub { - prf_desc; - prf_loc; - prf_attributes; - } = - let loc = sub.location sub prf_loc in - let attrs = sub.attributes sub prf_attributes in - let desc = match prf_desc with - | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - in - Rf.mk ~loc ~attrs desc - - let object_field sub { - pof_desc; - pof_loc; - pof_attributes; - } = - let loc = sub.location sub pof_loc in - let attrs = sub.attributes sub pof_attributes in - let desc = match pof_desc with - | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t) - | Oinherit t -> Oinherit (sub.typ sub t) - in - Of.mk ~loc ~attrs desc - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs; ptyp_loc_stack = _ } = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs - (List.map (map_loc sub) sl) (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - let loc = sub.location sub ptype_loc in - let attrs = sub.attributes sub ptype_attributes in - Type.mk ~loc ~attrs (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_loc; - ptyext_attributes} = - let loc = sub.location sub ptyext_loc in - let attrs = sub.attributes sub ptyext_attributes in - Te.mk ~loc ~attrs - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - - let map_type_exception sub - {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = - let loc = sub.location sub ptyexn_loc in - let attrs = sub.attributes sub ptyexn_attributes in - Te.mk_exception ~loc ~attrs - (sub.extension_constructor sub ptyexn_constructor) - - let map_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - let loc = sub.location sub pext_loc in - let attrs = sub.attributes sub pext_attributes in - Te.constructor ~loc ~attrs - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - - end - - module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (o, ct) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) - end - - module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (s, mt1, mt2) -> - functor_ ~loc ~attrs (map_loc sub s) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) mt1) - (sub.module_type sub mt2) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> - type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typesubst l -> - type_subst ~loc (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) - end - - - module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (arg, arg_ty, body) -> - functor_ ~loc ~attrs (map_loc sub arg) - (Migrate_parsetree_compiler_functions.may_map (sub.module_type sub) arg_ty) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - let attrs = sub.attributes sub attrs in - eval ~loc ~attrs (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_declaration sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) - end - - module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs; pexp_loc_stack = _ } = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs x - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> - send ~loc ~attrs (sub.expr sub e) (map_loc sub s) - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (o, e) -> - open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e) - | Pexp_letop {let_; ands; body} -> - letop ~loc ~attrs (sub.binding_op sub let_) - (List.map (sub.binding_op sub) ands) (sub.expr sub body) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () - - let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = - let open Exp in - let op = map_loc sub pbop_op in - let pat = sub.pat sub pbop_pat in - let exp = sub.expr sub pbop_exp in - let loc = sub.location sub pbop_loc in - binding_op op pat exp loc - - end - - module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs; ppat_loc_stack = _ } = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs c - | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) - end - - module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (o, ce) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> - inherit_ ~loc ~attrs o (sub.class_expr sub ce) - (map_opt (map_loc sub) s) - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - let loc = sub.location sub pci_loc in - let attrs = sub.attributes sub pci_attributes in - Ci.mk ~loc ~attrs - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) - end - - (* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - - let default_mapper = - { - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - type_exception = T.map_type_exception; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - binding_op = E.map_binding_op; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - module_substitution = - (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> - Ms.mk - (map_loc this pms_name) - (map_loc this pms_manifest) - ~attrs:(this.attributes this pms_attributes) - ~loc:(this.location this pms_loc) - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_declaration = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (this.module_expr this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - open_description = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this a -> - { - attr_name = map_loc this a.attr_name; - attr_payload = this.payload this a.attr_payload; - attr_loc = this.location this a.attr_loc - } - ); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - - let extension_of_error (error : Locations.location_error) : extension = - Locations.extension_of_error - ~mk_pstr:(fun x -> PStr x) - ~mk_extension:(fun x -> Str.extension x) - ~mk_string_constant:(fun x -> Str.eval (Exp.constant (Pconst_string (x, None)))) - error - - let attribute_of_warning loc s = - Attr.mk - {loc; txt = "ocaml.ppwarning" } - (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, None)))])) - - include Locations.Helpers_impl - - let cookies = ref String.Map.empty - - let get_cookie k = - try Some (String.Map.find k !cookies) - with Not_found -> None - - let set_cookie k v = - cookies := String.Map.add k v !cookies - - let tool_name_ref = ref "_none_" - - let tool_name () = !tool_name_ref - - - module PpxContext = struct - open Longident - open Asttypes - open Ast_helper - - let lid name = { txt = Lident name; loc = Location.none } - - let make_string x = Exp.constant (Pconst_string (x, None)) - - let make_bool x = - if x - then Exp.construct (lid "true") None - else Exp.construct (lid "false") None - - let rec make_list f lst = - match lst with - | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) - | [] -> - Exp.construct (lid "[]") None - - let make_pair f1 f2 (x1, x2) = - Exp.tuple [f1 x1; f2 x2] - - let make_option f opt = - match opt with - | Some x -> Exp.construct (lid "Some") (Some (f x)) - | None -> Exp.construct (lid "None") None - - let get_cookies () = - lid "cookies", - make_list (make_pair make_string (fun x -> x)) - (String.Map.bindings !cookies) - - let mk fields = - { - attr_name = { txt = "ocaml.ppx.context"; loc = Location.none }; - attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)]; - attr_loc = Location.none - } - - let make ~tool_name () = - let fields = - [ - lid "tool_name", make_string tool_name; - lid "include_dirs", make_list make_string !Clflags.include_dirs; - lid "load_path", make_list make_string (Migrate_parsetree_compiler_functions.get_load_paths ()); - lid "open_modules", make_list make_string !Clflags.open_modules; - lid "for_package", make_option make_string !Clflags.for_package; - lid "debug", make_bool !Clflags.debug; - lid "use_threads", make_bool !Clflags.use_threads; - lid "recursive_types", make_bool !Clflags.recursive_types; - lid "principal", make_bool !Clflags.principal; - lid "transparent_modules", make_bool !Clflags.transparent_modules; - lid "unboxed_types", make_bool (Migrate_parsetree_compiler_functions.get_unboxed_types ()); - get_cookies () - ] - in - mk fields - - let get_fields = function - | PStr [{pstr_desc = Pstr_eval - ({ pexp_desc = Pexp_record (fields, None); _ }, []); _}] -> - fields - | _ -> - raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" - - let restore fields = - let field name payload = - let rec get_string = function - | { pexp_desc = Pexp_constant (Pconst_string (str, None)); _ } -> str - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] string syntax" name - and get_bool pexp = - match pexp with - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"; _}, - None); _} -> - true - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"; _}, - None); _} -> - false - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] bool syntax" name - and get_list elem = function - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "::"; _}, - Some {pexp_desc = Pexp_tuple [exp; rest]; _}); _ } -> - elem exp :: get_list elem rest - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"; _}, None); _ } -> - [] - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] list syntax" name - and get_pair f1 f2 = function - | {pexp_desc = Pexp_tuple [e1; e2]; _} -> - (f1 e1, f2 e2) - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] pair syntax" name - and get_option elem = function - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "Some"; _ }, Some exp); _ } -> - Some (elem exp) - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "None"; _ }, None); _ } -> - None - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] option syntax" name - in - match name with - | "tool_name" -> - tool_name_ref := get_string payload - | "include_dirs" -> - Clflags.include_dirs := get_list get_string payload - | "load_path" -> - Migrate_parsetree_compiler_functions.load_path_init (get_list get_string payload) - | "open_modules" -> - Clflags.open_modules := get_list get_string payload - | "for_package" -> - Clflags.for_package := get_option get_string payload - | "debug" -> - Clflags.debug := get_bool payload - | "use_threads" -> - Clflags.use_threads := get_bool payload - | "recursive_types" -> - Clflags.recursive_types := get_bool payload - | "principal" -> - Clflags.principal := get_bool payload - | "transparent_modules" -> - Clflags.transparent_modules := get_bool payload - | "unboxed_types" -> - Migrate_parsetree_compiler_functions.set_unboxed_types (get_bool payload) - | "cookies" -> - let l = get_list (get_pair get_string (fun x -> x)) payload in - cookies := - List.fold_left - (fun s (k, v) -> String.Map.add k v s) String.Map.empty - l - | _ -> - () - in - List.iter (function ({txt=Lident name; _}, x) -> field name x | _ -> ()) fields - - let update_cookies fields = - let fields = - List.filter - (function ({txt=Lident "cookies"; _}, _) -> false | _ -> true) - fields - in - fields @ [get_cookies ()] - end - - let ppx_context = PpxContext.make - - let extension_of_exn exn = extension_of_error (Locations.location_error_of_exn exn) - - let apply_lazy ~source ~target mapper = - let implem ast = - let fields, ast = - match ast with - | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"; _}; - attr_payload = x; _}); _} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.structure mapper ast - with exn -> - [{pstr_desc = Pstr_extension (extension_of_exn exn, []); - pstr_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Str.attribute (PpxContext.mk fields) :: ast - in - let iface ast = - let fields, ast = - match ast with - | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"; _}; - attr_payload = x; - attr_loc = _}); _} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.signature mapper ast - with exn -> - [{psig_desc = Psig_extension (extension_of_exn exn, []); - psig_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Sig.attribute (PpxContext.mk fields) :: ast - in - - let ic = open_in_bin source in - let magic = - really_input_string ic (String.length Config.ast_impl_magic_number) - in - - let rewrite transform = - Location.input_name := input_value ic; - let ast = input_value ic in - close_in ic; - let ast = transform ast in - let oc = open_out_bin target in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc - and fail () = - close_in ic; - failwith "Ast_mapper: OCaml version mismatch or malformed input"; - in - - if magic = Config.ast_impl_magic_number then - rewrite (implem : structure -> structure) - else if magic = Config.ast_intf_magic_number then - rewrite (iface : signature -> signature) - else fail () - - let drop_ppx_context_str ~restore = function - | {pstr_desc = Pstr_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"; _}; - attr_payload = a; - attr_loc = _}; _ } - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - - let drop_ppx_context_sig ~restore = function - | {psig_desc = Psig_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"; _}; - attr_payload = a; - attr_loc = _}; _ } - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - - let add_ppx_context_str ~tool_name ast = - Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast - - let add_ppx_context_sig ~tool_name ast = - Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast - - - let apply ~source ~target mapper = - apply_lazy ~source ~target (fun () -> mapper) - - let run_main mapper = - try - let a = Sys.argv in - let n = Array.length a in - if n > 2 then - let mapper () = - try mapper (Array.to_list (Array.sub a 1 (n - 3))) - with exn -> - (* PR#6463 *) - let f _ _ = raise exn in - {default_mapper with structure = f; signature = f} - in - apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper - else begin - Printf.eprintf "Usage: %s [extra_args] \n%!" - Sys.executable_name; - exit 2 - end - with exn -> - prerr_endline (Printexc.to_string exn); - exit 2 + type variance (*IF_CURRENT = Asttypes.variance *) = + | Covariant + | Contravariant + | Invariant - let register_function = ref (fun _name f -> run_main f) - let register name f = !register_function name f end module Outcometree = struct @@ -4025,118 +201,3 @@ module Outcometree = struct | Ophr_signature of (out_sig_item * out_value option) list | Ophr_exception of (exn * out_value) end - -module Config = struct - let ast_impl_magic_number = "Caml1999M026" - let ast_intf_magic_number = "Caml1999N026" -end - -let map_signature mapper = mapper.Ast_mapper.signature mapper -let map_structure mapper = mapper.Ast_mapper.structure mapper - -let shallow_identity = - let id _ x = x in - { - Ast_mapper. - structure = id; - structure_item = id; - module_expr = id; - signature = id; - signature_item = id; - module_type = id; - with_constraint = id; - class_declaration = id; - class_expr = id; - class_field = id; - class_structure = id; - class_type = id; - class_type_field = id; - class_signature = id; - class_type_declaration = id; - class_description = id; - type_declaration = id; - type_kind = id; - typ = id; - type_extension = id; - extension_constructor = id; - value_description = id; - pat = id; - expr = id; - module_declaration = id; - module_type_declaration = id; - module_binding = id; - open_description = id; - include_description = id; - include_declaration = id; - value_binding = id; - constructor_declaration = id; - label_declaration = id; - cases = id; - case = id; - location = id; - extension = id; - attribute = id; - attributes = id; - payload = id; - binding_op = id; - module_substitution = id; - open_declaration = id; - type_exception = id; - } - -let failing_mapper = - let fail _ _ = - invalid_arg "failing_mapper: this mapper function should never get called" - in - { - Ast_mapper. - structure = fail; - structure_item = fail; - module_expr = fail; - signature = fail; - signature_item = fail; - module_type = fail; - with_constraint = fail; - class_declaration = fail; - class_expr = fail; - class_field = fail; - class_structure = fail; - class_type = fail; - class_type_field = fail; - class_signature = fail; - class_type_declaration = fail; - class_description = fail; - type_declaration = fail; - type_kind = fail; - typ = fail; - type_extension = fail; - extension_constructor = fail; - value_description = fail; - pat = fail; - expr = fail; - module_declaration = fail; - module_type_declaration = fail; - module_binding = fail; - open_description = fail; - include_description = fail; - include_declaration = fail; - value_binding = fail; - constructor_declaration = fail; - label_declaration = fail; - cases = fail; - case = fail; - location = fail; - extension = fail; - attribute = fail; - attributes = fail; - payload = fail; - binding_op = fail; - module_substitution = fail; - open_declaration = fail; - type_exception = fail; - } - -let make_top_mapper ~signature ~structure = - {failing_mapper with Ast_mapper. - signature = (fun _ x -> signature x); - structure = (fun _ x -> structure x) } diff --git a/src/vendored-omp/src/ast_410.ml b/src/vendored-omp/src/ast_410.ml index 749b14aa5..f74e922c8 100644 --- a/src/vendored-omp/src/ast_410.ml +++ b/src/vendored-omp/src/ast_410.ml @@ -17,3891 +17,53 @@ (* *) (**************************************************************************) -open Stdlib0 -open Ast_409_helper - -module Location = Location -module Longident = Longident - -[@@@warning "-9"] - -module Asttypes = struct - type constant (*IF_CURRENT = Asttypes.constant *) = - Const_int of int - | Const_char of char - | Const_string of string * string option - | Const_float of string - | Const_int32 of int32 - | Const_int64 of int64 - | Const_nativeint of nativeint - - type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive - - type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto - - (* Order matters, used in polymorphic comparison *) - type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - - type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - - type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - - type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh - - type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open - - type label = string - - type arg_label (*IF_CURRENT = Asttypes.arg_label *) = - Nolabel - | Labelled of string (* label:T -> ... *) - | Optional of string (* ?label:T -> ... *) - - type 'a loc = 'a Location.loc = { - txt : 'a; - loc : Location.t; - } - - - type variance (*IF_CURRENT = Asttypes.variance *) = - | Covariant - | Contravariant - | Invariant -end - -module Parsetree = struct - - open Asttypes - - type constant (*IF_CURRENT = Parsetree.constant *) = - Pconst_integer of string * char option - (* 3 3l 3L 3n - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker - *) - | Pconst_char of char - (* 'c' *) - | Pconst_string of string * string option - (* "constant" - {delim|other constant|delim} - *) - | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - - type location_stack = Location.t list - - (** {1 Extension points} *) - - type attribute (*IF_CURRENT = Parsetree.attribute *) = { - attr_name : string loc; - attr_payload : payload; - attr_loc : Location.t; - } - (* [@id ARG] - [@@id ARG] - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - - and extension = string loc * payload - (* [%id ARG] - [%%id ARG] - - Sub-language placeholder -- rejected by the typechecker. - *) - - and attributes = attribute list - - and payload (*IF_CURRENT = Parsetree.payload *) = - | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - - (** {1 Core language} *) - - (* Type expressions *) - - and core_type (*IF_CURRENT = Parsetree.core_type *) = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_loc_stack: location_stack; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional - *) - | Ptyp_tuple of core_type list - (* T1 * ... * Tn - - Invariant: n >= 2 - *) - | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of object_field list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). - - - As the core_type of a Pctf_method node. - - - As the core_type of a Pexp_poly node. - - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) - - and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) - - and row_field (*IF_CURRENT = Parsetree.row_field *) = { - prf_desc : row_field_desc; - prf_loc : Location.t; - prf_attributes : attributes; - } - - and row_field_desc (*IF_CURRENT = Parsetree.row_field_desc *) = - | Rtag of label loc * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 'bool' field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - *) - | Rinherit of core_type - (* [ T ] *) - - and object_field (*IF_CURRENT = Parsetree.object_field *) = { - pof_desc : object_field_desc; - pof_loc : Location.t; - pof_attributes : attributes; - } - - and object_field_desc (*IF_CURRENT = Parsetree.object_field_desc *) = - | Otag of label loc * core_type - | Oinherit of core_type - - (* Patterns *) - - and pattern (*IF_CURRENT = Parsetree.pattern *) = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_loc_stack: location_stack; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Ppat_interval of constant * constant - (* 'a'..'z' - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (* (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Ppat_construct of Longident.t loc * pattern option - (* C None - C P Some P - C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) - *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) - | Ppat_unpack of string option loc - (* (module P) Some "P" - (module _) None - - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of Longident.t loc * pattern - (* M.(P) *) - - (* Value expressions *) - - and expression (*IF_CURRENT = Parsetree.expression *) = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_loc_stack: location_stack; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = - | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) - | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_tuple of expression list - (* (E1, ..., En) - - Invariant: n >= 2 - *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) - | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) - | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * label loc - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of label loc * expression - (* x <- 2 *) - | Pexp_override of (label loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) - | Pexp_letmodule of string option loc * module_expr * expression - (* let module M = ME in E *) - | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) - | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) - | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string loc * expression - (* fun (type t) -> E *) - | Pexp_pack of module_expr - (* (module ME) - - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of open_declaration * expression - (* M.(E) - let open M in E - let! open M in E *) - | Pexp_letop of letop - (* let* P = E in E - let* P = E and* P = E in E *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable - (* . *) - - and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - - and letop (*IF_CURRENT = Parsetree.letop *) = - { - let_ : binding_op; - ands : binding_op list; - body : expression; - } - - and binding_op (*IF_CURRENT = Parsetree.binding_op *) = - { - pbop_op : string loc; - pbop_pat : pattern; - pbop_exp : expression; - pbop_loc : Location.t; - } - - (* Value descriptions *) - - and value_description (*IF_CURRENT = Parsetree.value_description *) = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } - -(* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) -*) - - (* Type declarations *) - - and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = - { - ptype_name: string loc; - ptype_params: (core_type * variance) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } - -(* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) -*) - - and type_kind (*IF_CURRENT = Parsetree.type_kind *) = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) - | Ptype_open - - and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l : T [@id1] [@id2] *) - } - - (* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. - *) - - and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = - { - pcd_name: string loc; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - -(* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) -*) - - and type_extension (*IF_CURRENT = Parsetree.type_extension *) = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * variance) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_loc: Location.t; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } -(* - type t += ... -*) - - and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - (* exception E *) - and type_exception (*IF_CURRENT = Parsetree.type_exception *) = - { - ptyexn_constructor: extension_constructor; - ptyexn_loc: Location.t; - ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = - Pext_decl of constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([T1; ...; Tn], None) - | C: T0 ([], Some T0) - | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) - *) - | Pext_rebind of Longident.t loc - (* - | C = D - *) - - (** {1 Class language} *) - - (* Type expressions for the class language *) - - and class_type (*IF_CURRENT = Parsetree.class_type *) = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = - | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) - | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - | Pcty_open of open_description * class_type - (* let open M in CT *) - - and class_signature (*IF_CURRENT = Parsetree.class_signature *) = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } - (* object('selfpat) ... end - object ... end (self = Ptyp_any) - *) - - and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = - | Pctf_inherit of class_type - (* inherit CT *) - | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) - - and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = - { - pci_virt: virtual_flag; - pci_params: (core_type * variance) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... - - Also used for "class type" declaration. - *) - - and class_description = class_type class_infos - - and class_type_declaration = class_type class_infos - - (* Value expressions for the class language *) - - and class_expr (*IF_CURRENT = Parsetree.class_expr *) = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = - | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - | Pcl_open of open_description * class_expr - (* let open M in CE *) - - - and class_structure (*IF_CURRENT = Parsetree.class_structure *) = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } - (* object(selfpat) ... end - object ... end (self = Ppat_any) - *) - - and class_field (*IF_CURRENT = Parsetree.class_field *) = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_field_desc (*IF_CURRENT = Parsetree.class_field_desc *) = - | Pcf_inherit of override_flag * class_expr * string loc option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) - | Pcf_val of (label loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) - | Pcf_method of (label loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) - - and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - - and class_declaration = class_expr class_infos - - (** {1 Module language} *) - - (* Type expressions for the module language *) - - and module_type (*IF_CURRENT = Parsetree.module_type *) = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) - | Pmty_functor of functor_parameter * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) - - and functor_parameter (*IF_CURRENT = Parsetree.functor_parameter *) = - | Unit - (* () *) - | Named of string option loc * module_type - (* (X : MT) Some X, MT - (_ : MT) None, MT *) - - and signature = signature_item list - - and signature_item (*IF_CURRENT = Parsetree.signature_item *) = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - - and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = - | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) - | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typesubst of type_declaration list - (* type t1 := ... and ... and tn := ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of type_exception - (* exception C of T *) - | Psig_module of module_declaration - (* module X = M - module X : MT *) - | Psig_modsubst of module_substitution - (* module X := M *) - | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) - | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) - | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) - - and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = - { - pmd_name: string option loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } - (* S : MT *) - - and module_substitution (*IF_CURRENT = Parsetree.module_substitution *) = - { - pms_name: string loc; - pms_manifest: Longident.t loc; - pms_attributes: attributes; (* ... [@@id1] [@@id2] *) - pms_loc: Location.t; - } - - and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } - (* S = MT - S (abstract module type declaration, pmtd_type = None) - *) - - and 'a open_infos (*IF_CURRENT = 'a Parsetree.open_infos *) = - { - popen_expr: 'a; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } - (* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) - - and open_description = Longident.t loc open_infos - (* open M.N - open M(N).O *) - - and open_declaration = module_expr open_infos - (* open M.N - open M(N).O - open struct ... end *) - - and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - - and include_description = module_type include_infos - (* include MT *) - - and include_declaration = module_expr include_infos - (* include ME *) - - and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = - | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) - | Pwith_typesubst of Longident.t loc * type_declaration - (* with type X.t := ..., same format as [Pwith_type] *) - | Pwith_modsubst of Longident.t loc * Longident.t loc - (* with module X.Y := Z *) - - (* Value expressions for the module language *) - - and module_expr (*IF_CURRENT = Parsetree.module_expr *) = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) - | Pmod_functor of functor_parameter * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) - - and structure = structure_item list - - and structure_item (*IF_CURRENT = Parsetree.structure_item *) = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - - and structure_item_desc (*IF_CURRENT = Parsetree.structure_item_desc *) = - | Pstr_eval of expression * attributes - (* E *) - | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) - | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) - | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) - | Pstr_exception of type_exception - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) - | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_declaration - (* open X *) - | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) - | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) - - and value_binding (*IF_CURRENT = Parsetree.value_binding *) = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - - and module_binding (*IF_CURRENT = Parsetree.module_binding *) = - { - pmb_name: string option loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } - (* X = ME *) - - (** {1 Toplevel} *) - - (* Toplevel phrases *) - - type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = - | Ptop_def of structure - | Ptop_dir of toplevel_directive - (* #use, #load ... *) - - and toplevel_directive (*IF_CURRENT = Parsetree.toplevel_directive *) = - { - pdir_name : string loc; - pdir_arg : directive_argument option; - pdir_loc : Location.t; - } - - and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = - { - pdira_desc : directive_argument_desc; - pdira_loc : Location.t; - } - - and directive_argument_desc (*IF_CURRENT = Parsetree.directive_argument_desc *) = - | Pdir_string of string - | Pdir_int of string * char option - | Pdir_ident of Longident.t - | Pdir_bool of bool - -end - -module Docstrings : sig - (** (Re)Initialise all docstring state *) - val init : unit -> unit - - (** Emit warnings for unattached and ambiguous docstrings *) - val warn_bad_docstrings : unit -> unit - - (** {2 Docstrings} *) - - (** Documentation comments *) - type docstring - - (** Create a docstring *) - val docstring : string -> Location.t -> docstring - - (** Register a docstring *) - val register : docstring -> unit - - (** Get the text of a docstring *) - val docstring_body : docstring -> string - - (** Get the location of a docstring *) - val docstring_loc : docstring -> Location.t - - (** {2 Set functions} - - These functions are used by the lexer to associate docstrings to - the locations of tokens. *) - - (** Docstrings immediately preceding a token *) - val set_pre_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately following a token *) - val set_post_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings not immediately adjacent to a token *) - val set_floating_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately following the token which precedes this one *) - val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately preceding the token which follows this one *) - val set_post_extra_docstrings : Lexing.position -> docstring list -> unit - - (** {2 Items} - - The {!docs} type represents documentation attached to an item. *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - val empty_docs : docs - - val docs_attr : docstring -> Parsetree.attribute - - (** Convert item documentation to attributes and add them to an - attribute list *) - val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) - val symbol_docs : unit -> docs - val symbol_docs_lazy : unit -> docs Lazy.t - - (** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) - val rhs_docs : int -> int -> docs - val rhs_docs_lazy : int -> int -> docs Lazy.t - - (** Mark the item documentation for the current symbol (for ambiguity - warnings). *) - val mark_symbol_docs : unit -> unit - - (** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) - val mark_rhs_docs : int -> int -> unit - - (** {2 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - - type info = docstring option - - val empty_info : info - - val info_attr : docstring -> Parsetree.attribute - - (** Convert field info to attributes and add them to an - attribute list *) - val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the field info for the current symbol. *) - val symbol_info : unit -> info - - (** Fetch the field info following the symbol at a given position. *) - val rhs_info : int -> info - - (** {2 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - - type text = docstring list - - val empty_text : text - val empty_text_lazy : text Lazy.t - - val text_attr : docstring -> Parsetree.attribute - - (** Convert text to attributes and add them to an attribute list *) - val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the text preceding the current symbol. *) - val symbol_text : unit -> text - val symbol_text_lazy : unit -> text Lazy.t - - (** Fetch the text preceding the symbol at the given position. *) - val rhs_text : int -> text - val rhs_text_lazy : int -> text Lazy.t - - (** {2 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - - (** Fetch additional text preceding the current symbol *) - val symbol_pre_extra_text : unit -> text - - (** Fetch additional text following the current symbol *) - val symbol_post_extra_text : unit -> text - - (** Fetch additional text preceding the symbol at the given position *) - val rhs_pre_extra_text : int -> text - - (** Fetch additional text following the symbol at the given position *) - val rhs_post_extra_text : int -> text - - (** Fetch text following the symbol at the given position *) - val rhs_post_text : int -> text - - module WithMenhir: sig - (** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) - val symbol_docs : Lexing.position * Lexing.position -> docs - val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t - - (** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) - val rhs_docs : Lexing.position -> Lexing.position -> docs - val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t - - (** Mark the item documentation for the current symbol (for ambiguity - warnings). *) - val mark_symbol_docs : Lexing.position * Lexing.position -> unit - - (** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) - val mark_rhs_docs : Lexing.position -> Lexing.position -> unit - - (** Fetch the field info for the current symbol. *) - val symbol_info : Lexing.position -> info - - (** Fetch the field info following the symbol at a given position. *) - val rhs_info : Lexing.position -> info - - (** Fetch the text preceding the current symbol. *) - val symbol_text : Lexing.position -> text - val symbol_text_lazy : Lexing.position -> text Lazy.t - - (** Fetch the text preceding the symbol at the given position. *) - val rhs_text : Lexing.position -> text - val rhs_text_lazy : Lexing.position -> text Lazy.t - - (** {3 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - - (** Fetch additional text preceding the current symbol *) - val symbol_pre_extra_text : Lexing.position -> text - - (** Fetch additional text following the current symbol *) - val symbol_post_extra_text : Lexing.position -> text - - (** Fetch additional text preceding the symbol at the given position *) - val rhs_pre_extra_text : Lexing.position -> text - - (** Fetch additional text following the symbol at the given position *) - val rhs_post_extra_text : Lexing.position -> text - - (** Fetch text following the symbol at the given position *) - val rhs_post_text : Lexing.position -> text - - end -end = struct - open Location - - (* Docstrings *) - - (* A docstring is "attached" if it has been inserted in the AST. This - is used for generating unexpected docstring warnings. *) - type ds_attached = - | Unattached (* Not yet attached anything.*) - | Info (* Attached to a field or constructor. *) - | Docs (* Attached to an item or as floating text. *) - - (* A docstring is "associated" with an item if there are no blank lines between - them. This is used for generating docstring ambiguity warnings. *) - type ds_associated = - | Zero (* Not associated with an item *) - | One (* Associated with one item *) - | Many (* Associated with multiple items (ambiguity) *) - - type docstring = - { ds_body: string; - ds_loc: Location.t; - mutable ds_attached: ds_attached; - mutable ds_associated: ds_associated; } - - (* List of docstrings *) - - let docstrings : docstring list ref = ref [] - - (* Warn for unused and ambiguous docstrings *) - - let warn_bad_docstrings () = - if Warnings.is_active (Migrate_parsetree_compiler_functions.bad_docstring true) then begin - List.iter - (fun ds -> - match ds.ds_attached with - | Info -> () - | Unattached -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring true) - | Docs -> - match ds.ds_associated with - | Zero | One -> () - | Many -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring false)) - (List.rev !docstrings) - end - - (* Docstring constructors and destructors *) - - let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; - ds_attached = Unattached; - ds_associated = Zero; } - in - ds - - let register ds = - docstrings := ds :: !docstrings - - let docstring_body ds = ds.ds_body - - let docstring_loc ds = ds.ds_loc - - (* Docstrings attached to items *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - let empty_docs = { docs_pre = None; docs_post = None } - - let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - - let docs_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - { attr_name = doc_loc; - attr_payload = PStr [item]; - attr_loc = Location.none } - - let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - - (* Docstrings attached to constructors or fields *) - - type info = docstring option - - let empty_info = None - - let info_attr = docs_attr - - let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - - (* Docstrings not attached to a specific item *) - - type text = docstring list - - let empty_text = [] - let empty_text_lazy = lazy [] - - let text_loc = {txt = "ocaml.text"; loc = Location.none} - - let text_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - { attr_name = text_loc; - attr_payload = PStr [item]; - attr_loc = Location.none } - - let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - - (* Find the first non-info docstring in a list, attach it and return it *) - let get_docstring ~info dsl = - let rec loop = function - | [] -> None - | {ds_attached = Info; _} :: rest -> loop rest - | ds :: _ -> - ds.ds_attached <- if info then Info else Docs; - Some ds - in - loop dsl - - (* Find all the non-info docstrings in a list, attach them and return them *) - let get_docstrings dsl = - let rec loop acc = function - | [] -> List.rev acc - | {ds_attached = Info; _} :: rest -> loop acc rest - | ds :: rest -> - ds.ds_attached <- Docs; - loop (ds :: acc) rest - in - loop [] dsl - - (* "Associate" all the docstrings in a list *) - let associate_docstrings dsl = - List.iter - (fun ds -> - match ds.ds_associated with - | Zero -> ds.ds_associated <- One - | (One | Many) -> ds.ds_associated <- Many) - dsl - - (* Map from positions to pre docstrings *) - - let pre_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_pre_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_table pos dsl - - let get_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - - let mark_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl - with Not_found -> () - - (* Map from positions to post docstrings *) - - let post_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_post_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_table pos dsl - - let get_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - - let mark_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl - with Not_found -> () - - let get_info pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstring ~info:true dsl - with Not_found -> None - - (* Map from positions to floating docstrings *) - - let floating_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_floating_docstrings pos dsl = - if dsl <> [] then Hashtbl.add floating_table pos dsl - - let get_text pos = - try - let dsl = Hashtbl.find floating_table pos in - get_docstrings dsl - with Not_found -> [] - - let get_post_text pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstrings dsl - with Not_found -> [] - - (* Maps from positions to extra docstrings *) - - let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_pre_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_extra_table pos dsl - - let get_pre_extra_text pos = - try - let dsl = Hashtbl.find pre_extra_table pos in - get_docstrings dsl - with Not_found -> [] - - let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_post_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_extra_table pos dsl - - let get_post_extra_text pos = - try - let dsl = Hashtbl.find post_extra_table pos in - get_docstrings dsl - with Not_found -> [] - - (* Docstrings from parser actions *) - module WithParsing = struct - let symbol_docs () = - { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); - docs_post = get_post_docs (Parsing.symbol_end_pos ()); } - - let symbol_docs_lazy () = - let p1 = Parsing.symbol_start_pos () in - let p2 = Parsing.symbol_end_pos () in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); - docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } - - let rhs_docs_lazy pos1 pos2 = - let p1 = Parsing.rhs_start_pos pos1 in - let p2 = Parsing.rhs_end_pos pos2 in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let mark_symbol_docs () = - mark_pre_docs (Parsing.symbol_start_pos ()); - mark_post_docs (Parsing.symbol_end_pos ()) - - let mark_rhs_docs pos1 pos2 = - mark_pre_docs (Parsing.rhs_start_pos pos1); - mark_post_docs (Parsing.rhs_end_pos pos2) - - let symbol_info () = - get_info (Parsing.symbol_end_pos ()) - - let rhs_info pos = - get_info (Parsing.rhs_end_pos pos) - - let symbol_text () = - get_text (Parsing.symbol_start_pos ()) - - let symbol_text_lazy () = - let pos = Parsing.symbol_start_pos () in - lazy (get_text pos) - - let rhs_text pos = - get_text (Parsing.rhs_start_pos pos) - - let rhs_post_text pos = - get_post_text (Parsing.rhs_end_pos pos) - - let rhs_text_lazy pos = - let pos = Parsing.rhs_start_pos pos in - lazy (get_text pos) - - let symbol_pre_extra_text () = - get_pre_extra_text (Parsing.symbol_start_pos ()) - - let symbol_post_extra_text () = - get_post_extra_text (Parsing.symbol_end_pos ()) - - let rhs_pre_extra_text pos = - get_pre_extra_text (Parsing.rhs_start_pos pos) - - let rhs_post_extra_text pos = - get_post_extra_text (Parsing.rhs_end_pos pos) - end - - include WithParsing - - module WithMenhir = struct - let symbol_docs (startpos, endpos) = - { docs_pre = get_pre_docs startpos; - docs_post = get_post_docs endpos; } - - let symbol_docs_lazy (p1, p2) = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs pos1; - docs_post = get_post_docs pos2; } - - let rhs_docs_lazy p1 p2 = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let mark_symbol_docs (startpos, endpos) = - mark_pre_docs startpos; - mark_post_docs endpos; - () - - let mark_rhs_docs pos1 pos2 = - mark_pre_docs pos1; - mark_post_docs pos2; - () - - let symbol_info endpos = - get_info endpos - - let rhs_info endpos = - get_info endpos - - let symbol_text startpos = - get_text startpos - - let symbol_text_lazy startpos = - lazy (get_text startpos) - - let rhs_text pos = - get_text pos - - let rhs_post_text pos = - get_post_text pos - - let rhs_text_lazy pos = - lazy (get_text pos) - - let symbol_pre_extra_text startpos = - get_pre_extra_text startpos - - let symbol_post_extra_text endpos = - get_post_extra_text endpos - - let rhs_pre_extra_text pos = - get_pre_extra_text pos - - let rhs_post_extra_text pos = - get_post_extra_text pos - end - - (* (Re)Initialise all comment state *) - - let init () = - docstrings := []; - Hashtbl.reset pre_table; - Hashtbl.reset post_table; - Hashtbl.reset floating_table; - Hashtbl.reset pre_extra_table; - Hashtbl.reset post_extra_table -end - -module Ast_helper : sig - open Asttypes - open Docstrings - open Parsetree - - type 'a with_loc = 'a Location.loc - type loc = Location.t - - type lid = Longident.t with_loc - type str = string with_loc - type str_opt = string option with_loc - type attrs = attribute list - - (** {1 Default locations} *) - - val default_loc: loc ref - (** Default value for all optional location arguments. *) - - val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - - (** {1 Constants} *) - - module Const : sig - val char : char -> constant - val string : ?quotation_delimiter:string -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant - end - - (** {1 Attributes} *) - module Attr : sig - val mk: ?loc:loc -> str -> payload -> attribute - end - - (** {1 Core language} *) - - (** Type expressions *) - module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - - (** Patterns *) - module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - - (** Expressions *) - module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr - -> expression -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression - -> expression - val letop: ?loc:loc -> ?attrs:attrs -> binding_op - -> binding_op list -> expression -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - val binding_op: str -> pattern -> expression -> loc -> binding_op - end - - (** Value declarations *) - module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - - (** Type declarations *) - module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * variance) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - - (** Type extensions *) - module Te: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * variance) list -> ?priv:private_flag -> - lid -> extension_constructor list -> type_extension - - val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - extension_constructor -> type_exception - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - - (** {1 Module language} *) - - (** Module type expressions *) - module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - - (** Module expressions *) - module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - - (** Signature items *) - module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_subst: ?loc:loc -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> type_exception -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val mod_subst: ?loc:loc -> module_substitution -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - - (** Structure items *) - module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> type_exception -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_declaration -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - - (** Module declarations *) - module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_type -> module_declaration - end - - (** Module substitutions *) - module Ms: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> lid -> module_substitution - end - - (** Module type declarations *) - module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - - (** Module bindings *) - module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_expr -> module_binding - end - - (** Opens *) - module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> 'a -> 'a open_infos - end - - (** Includes *) - module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - - (** Value bindings *) - module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - - (** {1 Class language} *) - - (** Class type expressions *) - module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type - -> class_type - end - - (** Class type fields *) - module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - - (** Class expressions *) - module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr - -> class_expr - end - - (** Class fields *) - module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - - (** Classes *) - module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> ?params:(core_type * variance) list -> - str -> 'a -> 'a class_infos - end - - (** Class signatures *) - module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - - (** Class structures *) - module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - - (** Row fields *) - module Rf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> bool -> core_type list -> row_field - val inherit_: ?loc:loc -> core_type -> row_field - end - - (** Object fields *) - module Of: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - object_field_desc -> object_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> core_type -> object_field - val inherit_: ?loc:loc -> core_type -> object_field - end - -end = struct - open Asttypes - open Parsetree - open Docstrings - - type 'a with_loc = 'a Location.loc - type loc = Location.t - - type lid = Longident.t with_loc - type str = string with_loc - type str_opt = string option with_loc - type attrs = attribute list - - let default_loc = ref Location.none - - let with_default_loc l f = - Misc.protect_refs [Misc.R (default_loc, l)] f - - module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (Int.to_string i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) - end - - module Attr = struct - let mk ?(loc= !default_loc) name payload = - { attr_name = name; - attr_payload = payload; - attr_loc = loc } - end - - module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; - ptyp_loc = loc; - ptyp_loc_stack = []; - ptyp_attributes = attrs} - - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - - let varify_constructors var_names t = - let check_variable vl loc v = - if List.mem v vl then - raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in - let var_names = List.map (fun v -> v.txt) var_names in - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> - check_variable var_names t.ptyp_loc x; - Ptyp_var x - | Ptyp_arrow (label,core_type,core_type') -> - Ptyp_arrow(label, loop core_type, loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr( { txt = Longident.Lident s }, []) - when List.mem s var_names -> - Ptyp_var s - | Ptyp_constr(longident, lst) -> - Ptyp_constr(longident, List.map loop lst) - | Ptyp_object (lst, o) -> - Ptyp_object (List.map loop_object_field lst, o) - | Ptyp_class (longident, lst) -> - Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) - in - {t with ptyp_desc = desc} - and loop_row_field field = - let prf_desc = match field.prf_desc with - | Rtag(label,flag,lst) -> - Rtag(label,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - in - { field with prf_desc; } - and loop_object_field field = - let pof_desc = match field.pof_desc with - | Otag(label, t) -> - Otag(label, loop t) - | Oinherit t -> - Oinherit (loop t) - in - { field with pof_desc; } - in - loop t - - end - - module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; - ppat_loc = loc; - ppat_loc_stack = []; - ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) - end - - module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b)) - let letop ?loc ?attrs let_ ands body = - mk ?loc ?attrs (Pexp_letop {let_; ands; body}) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - - let binding_op op pat exp loc = - { - pbop_op = op; - pbop_pat = pat; - pbop_exp = exp; - pbop_loc = loc; - } - end - - module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) - end - - module Mod = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg body = - mk ?loc ?attrs (Pmod_functor (arg, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) - end - - module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_subst ?loc a = mk ?loc (Psig_typesubst a) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let mod_subst ?loc a = mk ?loc (Psig_modsubst a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b)) - end - - module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b)) - end - - module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - - end - - module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - - end - - module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } - end - - module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } - end - - module Ms = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name syn = - { - pms_name = name; - pms_manifest = syn; - pms_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pms_loc = loc; - } - end - - module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } - end - - module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } - end - - module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) expr = - { - popen_expr = expr; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } - end - - module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - - end - - module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } - end - - module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } - end - - module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - - end - - (** Type extensions *) - module Te = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_loc = loc; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - constructor = - { - ptyexn_constructor = constructor; - ptyexn_loc = loc; - ptyexn_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - end - - module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } - end - - module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } - end - - (** Row fields *) - module Rf = struct - let mk ?(loc = !default_loc) ?(attrs = []) desc = { - prf_desc = desc; - prf_loc = loc; - prf_attributes = attrs; - } - let tag ?loc ?attrs label const tys = - mk ?loc ?attrs (Rtag (label, const, tys)) - let inherit_?loc ty = - mk ?loc (Rinherit ty) - end - - (** Object fields *) - module Of = struct - let mk ?(loc = !default_loc) ?(attrs=[]) desc = { - pof_desc = desc; - pof_loc = loc; - pof_attributes = attrs; - } - let tag ?loc ?attrs label ty = - mk ?loc ?attrs (Otag (label, ty)) - let inherit_ ?loc ty = - mk ?loc (Oinherit ty) - end -end - -module Ast_mapper : sig - open Parsetree - - (** {1 A generic Parsetree mapper} *) - - type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - (** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - - val default_mapper: mapper - (** A default mapper, which implements a "deep identity" mapping. *) - - (** {1 Apply mappers to compilation units} *) - - val tool_name: unit -> string - (** Can be used within a ppx preprocessor to know which tool is - calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], - ["ocaml"], ... Some global variables that reflect command-line - options are automatically synchronized between the calling tool - and the ppx preprocessor: {!Clflags.include_dirs}, - {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package}, - {!Clflags.debug}. *) - - - val apply: source:string -> target:string -> mapper -> unit - (** Apply a mapper (parametrized by the unit name) to a dumped - parsetree found in the [source] file and put the result in the - [target] file. The [structure] or [signature] field of the mapper - is applied to the implementation or interface. *) - - val run_main: (string list -> mapper) -> unit - (** Entry point to call to implement a standalone -ppx rewriter from a - mapper, parametrized by the command line arguments. The current - unit name can be obtained from {!Location.input_name}. This - function implements proper error reporting for uncaught - exceptions. *) - - (** {1 Registration API} *) - - val register_function: (string -> (string list -> mapper) -> unit) ref - - val register: string -> (string list -> mapper) -> unit - (** Apply the [register_function]. The default behavior is to run the - mapper immediately, taking arguments from the process command - line. This is to support a scenario where a mapper is linked as a - stand-alone executable. - - It is possible to overwrite the [register_function] to define - "-ppx drivers", which combine several mappers in a single process. - Typically, a driver starts by defining [register_function] to a - custom implementation, then lets ppx rewriters (linked statically - or dynamically) register themselves, and then run all or some of - them. It is also possible to have -ppx drivers apply rewriters to - only specific parts of an AST. - - The first argument to [register] is a symbolic name to be used by - the ppx driver. *) - - - (** {1 Convenience functions to write mappers} *) - - val map_opt: ('a -> 'b) -> 'a option -> 'b option - - val extension_of_error: Locations.location_error -> extension - (** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) +module Location = Location +module Longident = Longident - val attribute_of_warning: Location.t -> string -> attribute - (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) +[@@@warning "-9"] - include Locations.Helpers_intf +module Asttypes = struct + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * string option + | Const_float of string + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint - (** {1 Helper functions to call external mappers} *) + type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive - val add_ppx_context_str: - tool_name:string -> Parsetree.structure -> Parsetree.structure - (** Extract information from the current environment and encode it - into an attribute which is prepended to the list of structure - items in order to pass the information to an external - processor. *) + type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto - val add_ppx_context_sig: - tool_name:string -> Parsetree.signature -> Parsetree.signature - (** Same as [add_ppx_context_str], but for signatures. *) + (* Order matters, used in polymorphic comparison *) + type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - val drop_ppx_context_str: - restore:bool -> Parsetree.structure -> Parsetree.structure - (** Drop the ocaml.ppx.context attribute from a structure. If - [restore] is true, also restore the associated data in the current - process. *) + type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - val drop_ppx_context_sig: - restore:bool -> Parsetree.signature -> Parsetree.signature - (** Same as [drop_ppx_context_str], but for signatures. *) + type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - (** {1 Cookies} *) + type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh - (** Cookies are used to pass information from a ppx processor to - a further invocation of itself, when called from the OCaml - toplevel (or other tools that support cookies). *) + type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open - val set_cookie: string -> Parsetree.expression -> unit - val get_cookie: string -> Parsetree.expression option -end = struct - open Parsetree - open Ast_helper - open Location + type label = string - module String = Misc.Stdlib.String + type arg_label (*IF_CURRENT = Asttypes.arg_label *) = + Nolabel + | Labelled of string (* label:T -> ... *) + | Optional of string (* ?label:T -> ... *) - type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; + type 'a loc = 'a Location.loc = { + txt : 'a; + loc : Location.t; } - let map_fst f (x, y) = (f x, y) - let map_snd f (x, y) = (x, f y) - let map_tuple f1 f2 (x, y) = (f1 x, f2 y) - let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) - let map_opt f = function None -> None | Some x -> Some (f x) - - let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - - module T = struct - (* Type expressions for the core language *) - - let row_field sub { - prf_desc; - prf_loc; - prf_attributes; - } = - let loc = sub.location sub prf_loc in - let attrs = sub.attributes sub prf_attributes in - let desc = match prf_desc with - | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - in - Rf.mk ~loc ~attrs desc - - let object_field sub { - pof_desc; - pof_loc; - pof_attributes; - } = - let loc = sub.location sub pof_loc in - let attrs = sub.attributes sub pof_attributes in - let desc = match pof_desc with - | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t) - | Oinherit t -> Oinherit (sub.typ sub t) - in - Of.mk ~loc ~attrs desc - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs - (List.map (map_loc sub) sl) (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - let loc = sub.location sub ptype_loc in - let attrs = sub.attributes sub ptype_attributes in - Type.mk ~loc ~attrs (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_loc; - ptyext_attributes} = - let loc = sub.location sub ptyext_loc in - let attrs = sub.attributes sub ptyext_attributes in - Te.mk ~loc ~attrs - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - - let map_type_exception sub - {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = - let loc = sub.location sub ptyexn_loc in - let attrs = sub.attributes sub ptyexn_attributes in - Te.mk_exception ~loc ~attrs - (sub.extension_constructor sub ptyexn_constructor) - - let map_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - let loc = sub.location sub pext_loc in - let attrs = sub.attributes sub pext_attributes in - Te.constructor ~loc ~attrs - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - - end - - module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (o, ct) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) - end - - let map_functor_param sub = function - | Unit -> Unit - | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt) - - module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (param, mt) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_type sub mt) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> - type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typesubst l -> - type_subst ~loc (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) - end - - - module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (param, body) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - let attrs = sub.attributes sub attrs in - eval ~loc ~attrs (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_declaration sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) - end - - module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs x - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> - send ~loc ~attrs (sub.expr sub e) (map_loc sub s) - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (o, e) -> - open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e) - | Pexp_letop {let_; ands; body} -> - letop ~loc ~attrs (sub.binding_op sub let_) - (List.map (sub.binding_op sub) ands) (sub.expr sub body) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () - - let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = - let open Exp in - let op = map_loc sub pbop_op in - let pat = sub.pat sub pbop_pat in - let exp = sub.expr sub pbop_exp in - let loc = sub.location sub pbop_loc in - binding_op op pat exp loc - - end - - module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs c - | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) - end - - module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (o, ce) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> - inherit_ ~loc ~attrs o (sub.class_expr sub ce) - (map_opt (map_loc sub) s) - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - let loc = sub.location sub pci_loc in - let attrs = sub.attributes sub pci_attributes in - Ci.mk ~loc ~attrs - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) - end - - (* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - - let default_mapper = - { - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - type_exception = T.map_type_exception; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - binding_op = E.map_binding_op; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_substitution = - (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> - Ms.mk - (map_loc this pms_name) - (map_loc this pms_manifest) - ~attrs:(this.attributes this pms_attributes) - ~loc:(this.location this pms_loc) - ); - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_declaration = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (this.module_expr this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - open_description = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this a -> - { - attr_name = map_loc this a.attr_name; - attr_payload = this.payload this a.attr_payload; - attr_loc = this.location this a.attr_loc - } - ); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - - let extension_of_error (error : Locations.location_error) : extension = - Locations.extension_of_error - ~mk_pstr:(fun x -> PStr x) - ~mk_extension:(fun x -> Str.extension x) - ~mk_string_constant:(fun x -> Str.eval (Exp.constant (Pconst_string (x, None)))) - error - - let attribute_of_warning loc s = - Attr.mk - {loc; txt = "ocaml.ppwarning" } - (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, None)))])) - - include Locations.Helpers_impl - - let cookies = ref String.Map.empty - - let get_cookie k = - try Some (String.Map.find k !cookies) - with Not_found -> None - - let set_cookie k v = - cookies := String.Map.add k v !cookies - - let tool_name_ref = ref "_none_" - - let tool_name () = !tool_name_ref - - - module PpxContext = struct - open Longident - open Asttypes - open Ast_helper - - let lid name = { txt = Lident name; loc = Location.none } - - let make_string x = Exp.constant (Pconst_string (x, None)) - - let make_bool x = - if x - then Exp.construct (lid "true") None - else Exp.construct (lid "false") None - - let rec make_list f lst = - match lst with - | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) - | [] -> - Exp.construct (lid "[]") None - - let make_pair f1 f2 (x1, x2) = - Exp.tuple [f1 x1; f2 x2] - - let make_option f opt = - match opt with - | Some x -> Exp.construct (lid "Some") (Some (f x)) - | None -> Exp.construct (lid "None") None - - let get_cookies () = - lid "cookies", - make_list (make_pair make_string (fun x -> x)) - (String.Map.bindings !cookies) - - let mk fields = - { - attr_name = { txt = "ocaml.ppx.context"; loc = Location.none }; - attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)]; - attr_loc = Location.none - } - - let make ~tool_name () = - let fields = - [ - lid "tool_name", make_string tool_name; - lid "include_dirs", make_list make_string !Clflags.include_dirs; - lid "load_path", make_list make_string (Migrate_parsetree_compiler_functions.get_load_paths ()); - lid "open_modules", make_list make_string !Clflags.open_modules; - lid "for_package", make_option make_string !Clflags.for_package; - lid "debug", make_bool !Clflags.debug; - lid "use_threads", make_bool !Clflags.use_threads; - lid "use_vmthreads", make_bool false; - lid "recursive_types", make_bool !Clflags.recursive_types; - lid "principal", make_bool !Clflags.principal; - lid "transparent_modules", make_bool !Clflags.transparent_modules; - lid "unboxed_types", make_bool (Migrate_parsetree_compiler_functions.get_unboxed_types ()); - get_cookies () - ] - in - mk fields - - let get_fields = function - | PStr [{pstr_desc = Pstr_eval - ({ pexp_desc = Pexp_record (fields, None) }, [])}] -> - fields - | _ -> - raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" - - let restore fields = - let field name payload = - let rec get_string = function - | { pexp_desc = Pexp_constant (Pconst_string (str, None)) } -> str - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] string syntax" name - and get_bool pexp = - match pexp with - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, - None)} -> - true - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, - None)} -> - false - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] bool syntax" name - and get_list elem = function - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> - elem exp :: get_list elem rest - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> - [] - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] list syntax" name - and get_pair f1 f2 = function - | {pexp_desc = Pexp_tuple [e1; e2]} -> - (f1 e1, f2 e2) - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] pair syntax" name - and get_option elem = function - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> - Some (elem exp) - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> - None - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] option syntax" name - in - match name with - | "tool_name" -> - tool_name_ref := get_string payload - | "include_dirs" -> - Clflags.include_dirs := get_list get_string payload - | "load_path" -> - Migrate_parsetree_compiler_functions.load_path_init (get_list get_string payload) - | "open_modules" -> - Clflags.open_modules := get_list get_string payload - | "for_package" -> - Clflags.for_package := get_option get_string payload - | "debug" -> - Clflags.debug := get_bool payload - | "use_threads" -> - Clflags.use_threads := get_bool payload - | "use_vmthreads" -> - if get_bool payload then - raise_errorf "Internal error: vmthreads not supported after 4.09.0" - | "recursive_types" -> - Clflags.recursive_types := get_bool payload - | "principal" -> - Clflags.principal := get_bool payload - | "transparent_modules" -> - Clflags.transparent_modules := get_bool payload - | "unboxed_types" -> - Migrate_parsetree_compiler_functions.set_unboxed_types (get_bool payload) - | "cookies" -> - let l = get_list (get_pair get_string (fun x -> x)) payload in - cookies := - List.fold_left - (fun s (k, v) -> String.Map.add k v s) String.Map.empty - l - | _ -> - () - in - List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields - - let update_cookies fields = - let fields = - List.filter - (function ({txt=Lident "cookies"}, _) -> false | _ -> true) - fields - in - fields @ [get_cookies ()] - end - - let ppx_context = PpxContext.make - - let extension_of_exn exn = extension_of_error (Locations.location_error_of_exn exn) - - let apply_lazy ~source ~target mapper = - let implem ast = - let fields, ast = - match ast with - | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.structure mapper ast - with exn -> - [{pstr_desc = Pstr_extension (extension_of_exn exn, []); - pstr_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Str.attribute (PpxContext.mk fields) :: ast - in - let iface ast = - let fields, ast = - match ast with - | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x; - attr_loc = _})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.signature mapper ast - with exn -> - [{psig_desc = Psig_extension (extension_of_exn exn, []); - psig_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Sig.attribute (PpxContext.mk fields) :: ast - in - - let ic = open_in_bin source in - let magic = - really_input_string ic (String.length Config.ast_impl_magic_number) - in - - let rewrite transform = - Location.input_name := input_value ic; - let ast = input_value ic in - close_in ic; - let ast = transform ast in - let oc = open_out_bin target in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc - and fail () = - close_in ic; - failwith "Ast_mapper: OCaml version mismatch or malformed input"; - in - - if magic = Config.ast_impl_magic_number then - rewrite (implem : structure -> structure) - else if magic = Config.ast_intf_magic_number then - rewrite (iface : signature -> signature) - else fail () - - let drop_ppx_context_str ~restore = function - | {pstr_desc = Pstr_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - - let drop_ppx_context_sig ~restore = function - | {psig_desc = Psig_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - - let add_ppx_context_str ~tool_name ast = - Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast - - let add_ppx_context_sig ~tool_name ast = - Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast - - - let apply ~source ~target mapper = - apply_lazy ~source ~target (fun () -> mapper) - - let run_main mapper = - try - let a = Sys.argv in - let n = Array.length a in - if n > 2 then - let mapper () = - try mapper (Array.to_list (Array.sub a 1 (n - 3))) - with exn -> - (* PR#6463 *) - let f _ _ = raise exn in - {default_mapper with structure = f; signature = f} - in - apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper - else begin - Printf.eprintf "Usage: %s [extra_args] \n%!" - Sys.executable_name; - exit 2 - end - with exn -> - prerr_endline (Printexc.to_string exn); - exit 2 - - let register_function = ref (fun _name f -> run_main f) - let register name f = !register_function name f + type variance (*IF_CURRENT = Asttypes.variance *) = + | Covariant + | Contravariant + | Invariant end module Type_immediacy = struct @@ -4046,118 +208,3 @@ module Outcometree = struct | Ophr_signature of (out_sig_item * out_value option) list | Ophr_exception of (exn * out_value) end - -module Config = struct - let ast_impl_magic_number = "Caml1999M027" - let ast_intf_magic_number = "Caml1999N027" -end - -let map_signature mapper = mapper.Ast_mapper.signature mapper -let map_structure mapper = mapper.Ast_mapper.structure mapper - -let shallow_identity = - let id _ x = x in - { - Ast_mapper. - structure = id; - structure_item = id; - module_expr = id; - signature = id; - signature_item = id; - module_type = id; - with_constraint = id; - class_declaration = id; - class_expr = id; - class_field = id; - class_structure = id; - class_type = id; - class_type_field = id; - class_signature = id; - class_type_declaration = id; - class_description = id; - type_declaration = id; - type_kind = id; - typ = id; - type_extension = id; - extension_constructor = id; - value_description = id; - pat = id; - expr = id; - module_declaration = id; - module_type_declaration = id; - module_binding = id; - open_description = id; - include_description = id; - include_declaration = id; - value_binding = id; - constructor_declaration = id; - label_declaration = id; - cases = id; - case = id; - location = id; - extension = id; - attribute = id; - attributes = id; - payload = id; - binding_op = id; - module_substitution = id; - open_declaration = id; - type_exception = id; - } - -let failing_mapper = - let fail _ _ = - invalid_arg "failing_mapper: this mapper function should never get called" - in - { - Ast_mapper. - structure = fail; - structure_item = fail; - module_expr = fail; - signature = fail; - signature_item = fail; - module_type = fail; - with_constraint = fail; - class_declaration = fail; - class_expr = fail; - class_field = fail; - class_structure = fail; - class_type = fail; - class_type_field = fail; - class_signature = fail; - class_type_declaration = fail; - class_description = fail; - type_declaration = fail; - type_kind = fail; - typ = fail; - type_extension = fail; - extension_constructor = fail; - value_description = fail; - pat = fail; - expr = fail; - module_declaration = fail; - module_type_declaration = fail; - module_binding = fail; - open_description = fail; - include_description = fail; - include_declaration = fail; - value_binding = fail; - constructor_declaration = fail; - label_declaration = fail; - cases = fail; - case = fail; - location = fail; - extension = fail; - attribute = fail; - attributes = fail; - payload = fail; - binding_op = fail; - module_substitution = fail; - open_declaration = fail; - type_exception = fail; - } - -let make_top_mapper ~signature ~structure = - {failing_mapper with Ast_mapper. - signature = (fun _ x -> signature x); - structure = (fun _ x -> structure x) } diff --git a/src/vendored-omp/src/ast_411.ml b/src/vendored-omp/src/ast_411.ml index 4904f42d0..979ca2c36 100644 --- a/src/vendored-omp/src/ast_411.ml +++ b/src/vendored-omp/src/ast_411.ml @@ -17,3908 +17,53 @@ (* *) (**************************************************************************) -open Stdlib0 -open Ast_409_helper - -module Location = Location -module Longident = Longident - -[@@@warning "-9"] - -module Asttypes = struct - type constant (*IF_CURRENT = Asttypes.constant *) = - Const_int of int - | Const_char of char - | Const_string of string * Location.t * string option - | Const_float of string - | Const_int32 of int32 - | Const_int64 of int64 - | Const_nativeint of nativeint - - type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive - - type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto - - (* Order matters, used in polymorphic comparison *) - type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - - type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - - type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - - type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh - - type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open - - type label = string - - type arg_label (*IF_CURRENT = Asttypes.arg_label *) = - Nolabel - | Labelled of string (* label:T -> ... *) - | Optional of string (* ?label:T -> ... *) - - type 'a loc = 'a Location.loc = { - txt : 'a; - loc : Location.t; - } - - - type variance (*IF_CURRENT = Asttypes.variance *) = - | Covariant - | Contravariant - | Invariant -end - -module Parsetree = struct - open Asttypes - - type constant (*IF_CURRENT = Parsetree.constant *) = - Pconst_integer of string * char option - (* 3 3l 3L 3n - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker - *) - | Pconst_char of char - (* 'c' *) - | Pconst_string of string * Location.t * string option - (* "constant" - {delim|other constant|delim} - - The location span the content of the string, without the delimiters. - *) - | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - - type location_stack = Location.t list - - (** {1 Extension points} *) - - type attribute (*IF_CURRENT = Parsetree.attribute *) = { - attr_name : string loc; - attr_payload : payload; - attr_loc : Location.t; - } - (* [@id ARG] - [@@id ARG] - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - - and extension = string loc * payload - (* [%id ARG] - [%%id ARG] - - Sub-language placeholder -- rejected by the typechecker. - *) - - and attributes = attribute list - - and payload (*IF_CURRENT = Parsetree.payload *) = - | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - - (** {1 Core language} *) - - (* Type expressions *) - - and core_type (*IF_CURRENT = Parsetree.core_type *) = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_loc_stack: location_stack; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional - *) - | Ptyp_tuple of core_type list - (* T1 * ... * Tn - - Invariant: n >= 2 - *) - | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of object_field list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). - - - As the core_type of a Pctf_method node. - - - As the core_type of a Pexp_poly node. - - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) - - and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) - - and row_field (*IF_CURRENT = Parsetree.row_field *) = { - prf_desc : row_field_desc; - prf_loc : Location.t; - prf_attributes : attributes; - } - - and row_field_desc (*IF_CURRENT = Parsetree.row_field_desc *) = - | Rtag of label loc * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 'bool' field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - *) - | Rinherit of core_type - (* [ T ] *) - - and object_field (*IF_CURRENT = Parsetree.object_field *) = { - pof_desc : object_field_desc; - pof_loc : Location.t; - pof_attributes : attributes; - } - - and object_field_desc (*IF_CURRENT = Parsetree.object_field_desc *) = - | Otag of label loc * core_type - | Oinherit of core_type - - (* Patterns *) - - and pattern (*IF_CURRENT = Parsetree.pattern *) = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_loc_stack: location_stack; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Ppat_interval of constant * constant - (* 'a'..'z' - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (* (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Ppat_construct of Longident.t loc * pattern option - (* C None - C P Some P - C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) - *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) - | Ppat_unpack of string option loc - (* (module P) Some "P" - (module _) None - - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of Longident.t loc * pattern - (* M.(P) *) - - (* Value expressions *) - - and expression (*IF_CURRENT = Parsetree.expression *) = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_loc_stack: location_stack; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = - | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) - | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_tuple of expression list - (* (E1, ..., En) - - Invariant: n >= 2 - *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) - | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) - | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * label loc - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of label loc * expression - (* x <- 2 *) - | Pexp_override of (label loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) - | Pexp_letmodule of string option loc * module_expr * expression - (* let module M = ME in E *) - | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) - | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) - | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string loc * expression - (* fun (type t) -> E *) - | Pexp_pack of module_expr - (* (module ME) - - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of open_declaration * expression - (* M.(E) - let open M in E - let! open M in E *) - | Pexp_letop of letop - (* let* P = E in E - let* P = E and* P = E in E *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable - (* . *) - - and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - - and letop (*IF_CURRENT = Parsetree.letop *) = - { - let_ : binding_op; - ands : binding_op list; - body : expression; - } - - and binding_op (*IF_CURRENT = Parsetree.binding_op *) = - { - pbop_op : string loc; - pbop_pat : pattern; - pbop_exp : expression; - pbop_loc : Location.t; - } - - (* Value descriptions *) - - and value_description (*IF_CURRENT = Parsetree.value_description *) = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } - -(* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) -*) - - (* Type declarations *) - - and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = - { - ptype_name: string loc; - ptype_params: (core_type * variance) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } - -(* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) -*) - - and type_kind (*IF_CURRENT = Parsetree.type_kind *) = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) - | Ptype_open - - and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l : T [@id1] [@id2] *) - } - - (* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. - *) - - and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = - { - pcd_name: string loc; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - -(* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) -*) - - and type_extension (*IF_CURRENT = Parsetree.type_extension *) = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * variance) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_loc: Location.t; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } -(* - type t += ... -*) - - and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - (* exception E *) - and type_exception (*IF_CURRENT = Parsetree.type_exception *) = - { - ptyexn_constructor: extension_constructor; - ptyexn_loc: Location.t; - ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = - Pext_decl of constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([T1; ...; Tn], None) - | C: T0 ([], Some T0) - | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) - *) - | Pext_rebind of Longident.t loc - (* - | C = D - *) - - (** {1 Class language} *) - - (* Type expressions for the class language *) - - and class_type (*IF_CURRENT = Parsetree.class_type *) = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = - | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) - | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - | Pcty_open of open_description * class_type - (* let open M in CT *) - - and class_signature (*IF_CURRENT = Parsetree.class_signature *) = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } - (* object('selfpat) ... end - object ... end (self = Ptyp_any) - *) - - and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = - | Pctf_inherit of class_type - (* inherit CT *) - | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) - - and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = - { - pci_virt: virtual_flag; - pci_params: (core_type * variance) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... - - Also used for "class type" declaration. - *) - - and class_description = class_type class_infos - - and class_type_declaration = class_type class_infos - - (* Value expressions for the class language *) - - and class_expr (*IF_CURRENT = Parsetree.class_expr *) = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = - | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - | Pcl_open of open_description * class_expr - (* let open M in CE *) - - - and class_structure (*IF_CURRENT = Parsetree.class_structure *) = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } - (* object(selfpat) ... end - object ... end (self = Ppat_any) - *) - - and class_field (*IF_CURRENT = Parsetree.class_field *) = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_field_desc (*IF_CURRENT = Parsetree.class_field_desc *) = - | Pcf_inherit of override_flag * class_expr * string loc option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) - | Pcf_val of (label loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) - | Pcf_method of (label loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) - - and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - - and class_declaration = class_expr class_infos - - (** {1 Module language} *) - - (* Type expressions for the module language *) - - and module_type (*IF_CURRENT = Parsetree.module_type *) = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) - | Pmty_functor of functor_parameter * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) - - and functor_parameter (*IF_CURRENT = Parsetree.functor_parameter *) = - | Unit - (* () *) - | Named of string option loc * module_type - (* (X : MT) Some X, MT - (_ : MT) None, MT *) - - and signature = signature_item list - - and signature_item (*IF_CURRENT = Parsetree.signature_item *) = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - - and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = - | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) - | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typesubst of type_declaration list - (* type t1 := ... and ... and tn := ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of type_exception - (* exception C of T *) - | Psig_module of module_declaration - (* module X = M - module X : MT *) - | Psig_modsubst of module_substitution - (* module X := M *) - | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) - | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) - | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) - - and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = - { - pmd_name: string option loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } - (* S : MT *) - - and module_substitution (*IF_CURRENT = Parsetree.module_substitution *) = - { - pms_name: string loc; - pms_manifest: Longident.t loc; - pms_attributes: attributes; (* ... [@@id1] [@@id2] *) - pms_loc: Location.t; - } - - and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } - (* S = MT - S (abstract module type declaration, pmtd_type = None) - *) - - and 'a open_infos (*IF_CURRENT = 'a Parsetree.open_infos *) = - { - popen_expr: 'a; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } - (* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) - - and open_description = Longident.t loc open_infos - (* open M.N - open M(N).O *) - - and open_declaration = module_expr open_infos - (* open M.N - open M(N).O - open struct ... end *) - - and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - - and include_description = module_type include_infos - (* include MT *) - - and include_declaration = module_expr include_infos - (* include ME *) - - and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = - | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) - | Pwith_typesubst of Longident.t loc * type_declaration - (* with type X.t := ..., same format as [Pwith_type] *) - | Pwith_modsubst of Longident.t loc * Longident.t loc - (* with module X.Y := Z *) - - (* Value expressions for the module language *) - - and module_expr (*IF_CURRENT = Parsetree.module_expr *) = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) - | Pmod_functor of functor_parameter * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) - - and structure = structure_item list - - and structure_item (*IF_CURRENT = Parsetree.structure_item *) = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - - and structure_item_desc (*IF_CURRENT = Parsetree.structure_item_desc *) = - | Pstr_eval of expression * attributes - (* E *) - | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) - | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) - | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) - | Pstr_exception of type_exception - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) - | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_declaration - (* open X *) - | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) - | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) - - and value_binding (*IF_CURRENT = Parsetree.value_binding *) = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - - and module_binding (*IF_CURRENT = Parsetree.module_binding *) = - { - pmb_name: string option loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } - (* X = ME *) - - (** {1 Toplevel} *) - - (* Toplevel phrases *) - - type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = - | Ptop_def of structure - | Ptop_dir of toplevel_directive - (* #use, #load ... *) - - and toplevel_directive (*IF_CURRENT = Parsetree.toplevel_directive *) = - { - pdir_name : string loc; - pdir_arg : directive_argument option; - pdir_loc : Location.t; - } - - and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = - { - pdira_desc : directive_argument_desc; - pdira_loc : Location.t; - } - - and directive_argument_desc (*IF_CURRENT = Parsetree.directive_argument_desc *) = - | Pdir_string of string - | Pdir_int of string * char option - | Pdir_ident of Longident.t - | Pdir_bool of bool -end - -module Docstrings : sig - (** (Re)Initialise all docstring state *) - val init : unit -> unit - - (** Emit warnings for unattached and ambiguous docstrings *) - val warn_bad_docstrings : unit -> unit - - (** {2 Docstrings} *) - - (** Documentation comments *) - type docstring - - (** Create a docstring *) - val docstring : string -> Location.t -> docstring - - (** Register a docstring *) - val register : docstring -> unit - - (** Get the text of a docstring *) - val docstring_body : docstring -> string - - (** Get the location of a docstring *) - val docstring_loc : docstring -> Location.t - - (** {2 Set functions} - - These functions are used by the lexer to associate docstrings to - the locations of tokens. *) - - (** Docstrings immediately preceding a token *) - val set_pre_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately following a token *) - val set_post_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings not immediately adjacent to a token *) - val set_floating_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately following the token which precedes this one *) - val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately preceding the token which follows this one *) - val set_post_extra_docstrings : Lexing.position -> docstring list -> unit - - (** {2 Items} - - The {!docs} type represents documentation attached to an item. *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - val empty_docs : docs - - val docs_attr : docstring -> Parsetree.attribute - - (** Convert item documentation to attributes and add them to an - attribute list *) - val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) - val symbol_docs : unit -> docs - val symbol_docs_lazy : unit -> docs Lazy.t - - (** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) - val rhs_docs : int -> int -> docs - val rhs_docs_lazy : int -> int -> docs Lazy.t - - (** Mark the item documentation for the current symbol (for ambiguity - warnings). *) - val mark_symbol_docs : unit -> unit - - (** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) - val mark_rhs_docs : int -> int -> unit - - (** {2 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - - type info = docstring option - - val empty_info : info - - val info_attr : docstring -> Parsetree.attribute - - (** Convert field info to attributes and add them to an - attribute list *) - val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the field info for the current symbol. *) - val symbol_info : unit -> info - - (** Fetch the field info following the symbol at a given position. *) - val rhs_info : int -> info - - (** {2 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - - type text = docstring list - - val empty_text : text - val empty_text_lazy : text Lazy.t - - val text_attr : docstring -> Parsetree.attribute - - (** Convert text to attributes and add them to an attribute list *) - val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the text preceding the current symbol. *) - val symbol_text : unit -> text - val symbol_text_lazy : unit -> text Lazy.t - - (** Fetch the text preceding the symbol at the given position. *) - val rhs_text : int -> text - val rhs_text_lazy : int -> text Lazy.t - - (** {2 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - - (** Fetch additional text preceding the current symbol *) - val symbol_pre_extra_text : unit -> text - - (** Fetch additional text following the current symbol *) - val symbol_post_extra_text : unit -> text - - (** Fetch additional text preceding the symbol at the given position *) - val rhs_pre_extra_text : int -> text - - (** Fetch additional text following the symbol at the given position *) - val rhs_post_extra_text : int -> text - - (** Fetch text following the symbol at the given position *) - val rhs_post_text : int -> text - - module WithMenhir: sig - (** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) - val symbol_docs : Lexing.position * Lexing.position -> docs - val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t - - (** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) - val rhs_docs : Lexing.position -> Lexing.position -> docs - val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t - - (** Mark the item documentation for the current symbol (for ambiguity - warnings). *) - val mark_symbol_docs : Lexing.position * Lexing.position -> unit - - (** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) - val mark_rhs_docs : Lexing.position -> Lexing.position -> unit - - (** Fetch the field info for the current symbol. *) - val symbol_info : Lexing.position -> info - - (** Fetch the field info following the symbol at a given position. *) - val rhs_info : Lexing.position -> info - - (** Fetch the text preceding the current symbol. *) - val symbol_text : Lexing.position -> text - val symbol_text_lazy : Lexing.position -> text Lazy.t - - (** Fetch the text preceding the symbol at the given position. *) - val rhs_text : Lexing.position -> text - val rhs_text_lazy : Lexing.position -> text Lazy.t - - (** {3 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - - (** Fetch additional text preceding the current symbol *) - val symbol_pre_extra_text : Lexing.position -> text - - (** Fetch additional text following the current symbol *) - val symbol_post_extra_text : Lexing.position -> text - - (** Fetch additional text preceding the symbol at the given position *) - val rhs_pre_extra_text : Lexing.position -> text - - (** Fetch additional text following the symbol at the given position *) - val rhs_post_extra_text : Lexing.position -> text - - (** Fetch text following the symbol at the given position *) - val rhs_post_text : Lexing.position -> text - - end -end = struct - open Location - - (* Docstrings *) - - (* A docstring is "attached" if it has been inserted in the AST. This - is used for generating unexpected docstring warnings. *) - type ds_attached = - | Unattached (* Not yet attached anything.*) - | Info (* Attached to a field or constructor. *) - | Docs (* Attached to an item or as floating text. *) - - (* A docstring is "associated" with an item if there are no blank lines between - them. This is used for generating docstring ambiguity warnings. *) - type ds_associated = - | Zero (* Not associated with an item *) - | One (* Associated with one item *) - | Many (* Associated with multiple items (ambiguity) *) - - type docstring = - { ds_body: string; - ds_loc: Location.t; - mutable ds_attached: ds_attached; - mutable ds_associated: ds_associated; } - - (* List of docstrings *) - - let docstrings : docstring list ref = ref [] - - (* Warn for unused and ambiguous docstrings *) - - let warn_bad_docstrings () = - if Warnings.is_active (Migrate_parsetree_compiler_functions.bad_docstring true) then begin - List.iter - (fun ds -> - match ds.ds_attached with - | Info -> () - | Unattached -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring true) - | Docs -> - match ds.ds_associated with - | Zero | One -> () - | Many -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring false)) - (List.rev !docstrings) - end - - (* Docstring constructors and destructors *) - - let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; - ds_attached = Unattached; - ds_associated = Zero; } - in - ds - - let register ds = - docstrings := ds :: !docstrings - - let docstring_body ds = ds.ds_body - - let docstring_loc ds = ds.ds_loc - - (* Docstrings attached to items *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - let empty_docs = { docs_pre = None; docs_post = None } - - let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - - let docs_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, ds.ds_loc, None)); - pexp_loc = ds.ds_loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - { attr_name = doc_loc; - attr_payload = PStr [item]; - attr_loc = Location.none } - - let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - - (* Docstrings attached to constructors or fields *) - - type info = docstring option - - let empty_info = None - - let info_attr = docs_attr - - let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - - (* Docstrings not attached to a specific item *) - - type text = docstring list - - let empty_text = [] - let empty_text_lazy = lazy [] - - let text_loc = {txt = "ocaml.text"; loc = Location.none} - - let text_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, ds.ds_loc, None)); - pexp_loc = ds.ds_loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - { attr_name = text_loc; - attr_payload = PStr [item]; - attr_loc = Location.none } - - let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - - (* Find the first non-info docstring in a list, attach it and return it *) - let get_docstring ~info dsl = - let rec loop = function - | [] -> None - | {ds_attached = Info; _} :: rest -> loop rest - | ds :: _ -> - ds.ds_attached <- if info then Info else Docs; - Some ds - in - loop dsl - - (* Find all the non-info docstrings in a list, attach them and return them *) - let get_docstrings dsl = - let rec loop acc = function - | [] -> List.rev acc - | {ds_attached = Info; _} :: rest -> loop acc rest - | ds :: rest -> - ds.ds_attached <- Docs; - loop (ds :: acc) rest - in - loop [] dsl - - (* "Associate" all the docstrings in a list *) - let associate_docstrings dsl = - List.iter - (fun ds -> - match ds.ds_associated with - | Zero -> ds.ds_associated <- One - | (One | Many) -> ds.ds_associated <- Many) - dsl - - (* Map from positions to pre docstrings *) - - let pre_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_pre_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_table pos dsl - - let get_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - - let mark_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl - with Not_found -> () - - (* Map from positions to post docstrings *) - - let post_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_post_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_table pos dsl - - let get_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - - let mark_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl - with Not_found -> () - - let get_info pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstring ~info:true dsl - with Not_found -> None - - (* Map from positions to floating docstrings *) - - let floating_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_floating_docstrings pos dsl = - if dsl <> [] then Hashtbl.add floating_table pos dsl - - let get_text pos = - try - let dsl = Hashtbl.find floating_table pos in - get_docstrings dsl - with Not_found -> [] - - let get_post_text pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstrings dsl - with Not_found -> [] - - (* Maps from positions to extra docstrings *) - - let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_pre_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_extra_table pos dsl - - let get_pre_extra_text pos = - try - let dsl = Hashtbl.find pre_extra_table pos in - get_docstrings dsl - with Not_found -> [] - - let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_post_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_extra_table pos dsl - - let get_post_extra_text pos = - try - let dsl = Hashtbl.find post_extra_table pos in - get_docstrings dsl - with Not_found -> [] - - (* Docstrings from parser actions *) - module WithParsing = struct - let symbol_docs () = - { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); - docs_post = get_post_docs (Parsing.symbol_end_pos ()); } - - let symbol_docs_lazy () = - let p1 = Parsing.symbol_start_pos () in - let p2 = Parsing.symbol_end_pos () in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); - docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } - - let rhs_docs_lazy pos1 pos2 = - let p1 = Parsing.rhs_start_pos pos1 in - let p2 = Parsing.rhs_end_pos pos2 in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let mark_symbol_docs () = - mark_pre_docs (Parsing.symbol_start_pos ()); - mark_post_docs (Parsing.symbol_end_pos ()) - - let mark_rhs_docs pos1 pos2 = - mark_pre_docs (Parsing.rhs_start_pos pos1); - mark_post_docs (Parsing.rhs_end_pos pos2) - - let symbol_info () = - get_info (Parsing.symbol_end_pos ()) - - let rhs_info pos = - get_info (Parsing.rhs_end_pos pos) - - let symbol_text () = - get_text (Parsing.symbol_start_pos ()) - - let symbol_text_lazy () = - let pos = Parsing.symbol_start_pos () in - lazy (get_text pos) - - let rhs_text pos = - get_text (Parsing.rhs_start_pos pos) - - let rhs_post_text pos = - get_post_text (Parsing.rhs_end_pos pos) - - let rhs_text_lazy pos = - let pos = Parsing.rhs_start_pos pos in - lazy (get_text pos) - - let symbol_pre_extra_text () = - get_pre_extra_text (Parsing.symbol_start_pos ()) - - let symbol_post_extra_text () = - get_post_extra_text (Parsing.symbol_end_pos ()) - - let rhs_pre_extra_text pos = - get_pre_extra_text (Parsing.rhs_start_pos pos) - - let rhs_post_extra_text pos = - get_post_extra_text (Parsing.rhs_end_pos pos) - end - - include WithParsing - - module WithMenhir = struct - let symbol_docs (startpos, endpos) = - { docs_pre = get_pre_docs startpos; - docs_post = get_post_docs endpos; } - - let symbol_docs_lazy (p1, p2) = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs pos1; - docs_post = get_post_docs pos2; } - - let rhs_docs_lazy p1 p2 = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let mark_symbol_docs (startpos, endpos) = - mark_pre_docs startpos; - mark_post_docs endpos; - () - - let mark_rhs_docs pos1 pos2 = - mark_pre_docs pos1; - mark_post_docs pos2; - () - - let symbol_info endpos = - get_info endpos - - let rhs_info endpos = - get_info endpos - - let symbol_text startpos = - get_text startpos - - let symbol_text_lazy startpos = - lazy (get_text startpos) - - let rhs_text pos = - get_text pos - - let rhs_post_text pos = - get_post_text pos - - let rhs_text_lazy pos = - lazy (get_text pos) - - let symbol_pre_extra_text startpos = - get_pre_extra_text startpos - - let symbol_post_extra_text endpos = - get_post_extra_text endpos - - let rhs_pre_extra_text pos = - get_pre_extra_text pos - - let rhs_post_extra_text pos = - get_post_extra_text pos - end - - (* (Re)Initialise all comment state *) - - let init () = - docstrings := []; - Hashtbl.reset pre_table; - Hashtbl.reset post_table; - Hashtbl.reset floating_table; - Hashtbl.reset pre_extra_table; - Hashtbl.reset post_extra_table -end - -module Ast_helper : sig - open Asttypes - open Docstrings - open Parsetree - - type 'a with_loc = 'a Location.loc - type loc = Location.t - - type lid = Longident.t with_loc - type str = string with_loc - type str_opt = string option with_loc - type attrs = attribute list - - (** {1 Default locations} *) - - val default_loc: loc ref - (** Default value for all optional location arguments. *) - - val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - - (** {1 Constants} *) - - module Const : sig - val char : char -> constant - val string : - ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant - end - - (** {1 Attributes} *) - module Attr : sig - val mk: ?loc:loc -> str -> payload -> attribute - end - - (** {1 Core language} *) - - (** Type expressions *) - module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - - (** Patterns *) - module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - - (** Expressions *) - module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr - -> expression -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression - -> expression - val letop: ?loc:loc -> ?attrs:attrs -> binding_op - -> binding_op list -> expression -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - val binding_op: str -> pattern -> expression -> loc -> binding_op - end - - (** Value declarations *) - module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - - (** Type declarations *) - module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * variance) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - - (** Type extensions *) - module Te: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * variance) list -> ?priv:private_flag -> - lid -> extension_constructor list -> type_extension - - val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - extension_constructor -> type_exception - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - - (** {1 Module language} *) - - (** Module type expressions *) - module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - - (** Module expressions *) - module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - - (** Signature items *) - module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_subst: ?loc:loc -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> type_exception -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val mod_subst: ?loc:loc -> module_substitution -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - - (** Structure items *) - module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> type_exception -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_declaration -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - - (** Module declarations *) - module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_type -> module_declaration - end - - (** Module substitutions *) - module Ms: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> lid -> module_substitution - end - - (** Module type declarations *) - module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - - (** Module bindings *) - module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_expr -> module_binding - end - - (** Opens *) - module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> 'a -> 'a open_infos - end - - (** Includes *) - module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - - (** Value bindings *) - module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - - (** {1 Class language} *) - - (** Class type expressions *) - module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type - -> class_type - end - - (** Class type fields *) - module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - - (** Class expressions *) - module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr - -> class_expr - end - - (** Class fields *) - module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - - (** Classes *) - module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> ?params:(core_type * variance) list -> - str -> 'a -> 'a class_infos - end - - (** Class signatures *) - module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - - (** Class structures *) - module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - - (** Row fields *) - module Rf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> bool -> core_type list -> row_field - val inherit_: ?loc:loc -> core_type -> row_field - end - - (** Object fields *) - module Of: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - object_field_desc -> object_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> core_type -> object_field - val inherit_: ?loc:loc -> core_type -> object_field - end -end = struct - open Asttypes - open Parsetree - open Docstrings - - type 'a with_loc = 'a Location.loc - type loc = Location.t - - type lid = Longident.t with_loc - type str = string with_loc - type str_opt = string option with_loc - type attrs = attribute list - - let default_loc = ref Location.none - - let with_default_loc l f = - Misc.protect_refs [Misc.R (default_loc, l)] f - - module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (Int.to_string i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter ?(loc= !default_loc) s = - Pconst_string (s, loc, quotation_delimiter) - end - - module Attr = struct - let mk ?(loc= !default_loc) name payload = - { attr_name = name; - attr_payload = payload; - attr_loc = loc } - end - - module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; - ptyp_loc = loc; - ptyp_loc_stack = []; - ptyp_attributes = attrs} - - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - - let varify_constructors var_names t = - let check_variable vl loc v = - if List.mem v vl then - raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in - let var_names = List.map (fun v -> v.txt) var_names in - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> - check_variable var_names t.ptyp_loc x; - Ptyp_var x - | Ptyp_arrow (label,core_type,core_type') -> - Ptyp_arrow(label, loop core_type, loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr( { txt = Longident.Lident s }, []) - when List.mem s var_names -> - Ptyp_var s - | Ptyp_constr(longident, lst) -> - Ptyp_constr(longident, List.map loop lst) - | Ptyp_object (lst, o) -> - Ptyp_object (List.map loop_object_field lst, o) - | Ptyp_class (longident, lst) -> - Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) - in - {t with ptyp_desc = desc} - and loop_row_field field = - let prf_desc = match field.prf_desc with - | Rtag(label,flag,lst) -> - Rtag(label,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - in - { field with prf_desc; } - and loop_object_field field = - let pof_desc = match field.pof_desc with - | Otag(label, t) -> - Otag(label, loop t) - | Oinherit t -> - Oinherit (loop t) - in - { field with pof_desc; } - in - loop t - - end - - module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; - ppat_loc = loc; - ppat_loc_stack = []; - ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) - end - - module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b)) - let letop ?loc ?attrs let_ ands body = - mk ?loc ?attrs (Pexp_letop {let_; ands; body}) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - - let binding_op op pat exp loc = - { - pbop_op = op; - pbop_pat = pat; - pbop_exp = exp; - pbop_loc = loc; - } - end - - module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) - end - - module Mod = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg body = - mk ?loc ?attrs (Pmod_functor (arg, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) - end - - module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_subst ?loc a = mk ?loc (Psig_typesubst a) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let mod_subst ?loc a = mk ?loc (Psig_modsubst a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b)) - end - - module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b)) - end - - module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - - end - - module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - - end - - module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } - end - - module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } - end - - module Ms = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name syn = - { - pms_name = name; - pms_manifest = syn; - pms_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pms_loc = loc; - } - end - - module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } - end - - module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } - end - - module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) expr = - { - popen_expr = expr; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } - end - - module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - - end - - module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } - end - - module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } - end - - module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - - end - - (** Type extensions *) - module Te = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_loc = loc; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - constructor = - { - ptyexn_constructor = constructor; - ptyexn_loc = loc; - ptyexn_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - end - - module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } - end - - module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } - end - - (** Row fields *) - module Rf = struct - let mk ?(loc = !default_loc) ?(attrs = []) desc = { - prf_desc = desc; - prf_loc = loc; - prf_attributes = attrs; - } - let tag ?loc ?attrs label const tys = - mk ?loc ?attrs (Rtag (label, const, tys)) - let inherit_?loc ty = - mk ?loc (Rinherit ty) - end - - (** Object fields *) - module Of = struct - let mk ?(loc = !default_loc) ?(attrs=[]) desc = { - pof_desc = desc; - pof_loc = loc; - pof_attributes = attrs; - } - let tag ?loc ?attrs label ty = - mk ?loc ?attrs (Otag (label, ty)) - let inherit_ ?loc ty = - mk ?loc (Oinherit ty) - end -end - -module Ast_mapper : sig - open Parsetree - - (** {1 A generic Parsetree mapper} *) - - type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - (** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - - val default_mapper: mapper - (** A default mapper, which implements a "deep identity" mapping. *) - - (** {1 Apply mappers to compilation units} *) - - val tool_name: unit -> string - (** Can be used within a ppx preprocessor to know which tool is - calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], - ["ocaml"], ... Some global variables that reflect command-line - options are automatically synchronized between the calling tool - and the ppx preprocessor: {!Clflags.include_dirs}, - {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package}, - {!Clflags.debug}. *) - - - val apply: source:string -> target:string -> mapper -> unit - (** Apply a mapper (parametrized by the unit name) to a dumped - parsetree found in the [source] file and put the result in the - [target] file. The [structure] or [signature] field of the mapper - is applied to the implementation or interface. *) - - val run_main: (string list -> mapper) -> unit - (** Entry point to call to implement a standalone -ppx rewriter from a - mapper, parametrized by the command line arguments. The current - unit name can be obtained from {!Location.input_name}. This - function implements proper error reporting for uncaught - exceptions. *) - - (** {1 Registration API} *) - - val register_function: (string -> (string list -> mapper) -> unit) ref - - val register: string -> (string list -> mapper) -> unit - (** Apply the [register_function]. The default behavior is to run the - mapper immediately, taking arguments from the process command - line. This is to support a scenario where a mapper is linked as a - stand-alone executable. - - It is possible to overwrite the [register_function] to define - "-ppx drivers", which combine several mappers in a single process. - Typically, a driver starts by defining [register_function] to a - custom implementation, then lets ppx rewriters (linked statically - or dynamically) register themselves, and then run all or some of - them. It is also possible to have -ppx drivers apply rewriters to - only specific parts of an AST. - - The first argument to [register] is a symbolic name to be used by - the ppx driver. *) - - - (** {1 Convenience functions to write mappers} *) - - val map_opt: ('a -> 'b) -> 'a option -> 'b option - - val extension_of_error: Locations.location_error -> extension - (** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) +module Location = Location +module Longident = Longident - val attribute_of_warning: Location.t -> string -> attribute - (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) +[@@@warning "-9"] - include Locations.Helpers_intf +module Asttypes = struct + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * Location.t * string option + | Const_float of string + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint - (** {1 Helper functions to call external mappers} *) + type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive - val add_ppx_context_str: - tool_name:string -> Parsetree.structure -> Parsetree.structure - (** Extract information from the current environment and encode it - into an attribute which is prepended to the list of structure - items in order to pass the information to an external - processor. *) + type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto - val add_ppx_context_sig: - tool_name:string -> Parsetree.signature -> Parsetree.signature - (** Same as [add_ppx_context_str], but for signatures. *) + (* Order matters, used in polymorphic comparison *) + type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - val drop_ppx_context_str: - restore:bool -> Parsetree.structure -> Parsetree.structure - (** Drop the ocaml.ppx.context attribute from a structure. If - [restore] is true, also restore the associated data in the current - process. *) + type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - val drop_ppx_context_sig: - restore:bool -> Parsetree.signature -> Parsetree.signature - (** Same as [drop_ppx_context_str], but for signatures. *) + type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - (** {1 Cookies} *) + type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh - (** Cookies are used to pass information from a ppx processor to - a further invocation of itself, when called from the OCaml - toplevel (or other tools that support cookies). *) + type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open - val set_cookie: string -> Parsetree.expression -> unit - val get_cookie: string -> Parsetree.expression option -end = struct - open Parsetree - open Ast_helper - open Location + type label = string - module String = Misc.Stdlib.String + type arg_label (*IF_CURRENT = Asttypes.arg_label *) = + Nolabel + | Labelled of string (* label:T -> ... *) + | Optional of string (* ?label:T -> ... *) - type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; + type 'a loc = 'a Location.loc = { + txt : 'a; + loc : Location.t; } - let map_fst f (x, y) = (f x, y) - let map_snd f (x, y) = (x, f y) - let map_tuple f1 f2 (x, y) = (f1 x, f2 y) - let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) - let map_opt f = function None -> None | Some x -> Some (f x) - - let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - - module C = struct - (* Constants *) - - let map sub c = match c with - | Pconst_integer _ - | Pconst_char _ - | Pconst_float _ - -> c - | Pconst_string (s, loc, quotation_delimiter) -> - let loc = sub.location sub loc in - Const.string ~loc ?quotation_delimiter s - end - - module T = struct - (* Type expressions for the core language *) - - let row_field sub { - prf_desc; - prf_loc; - prf_attributes; - } = - let loc = sub.location sub prf_loc in - let attrs = sub.attributes sub prf_attributes in - let desc = match prf_desc with - | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - in - Rf.mk ~loc ~attrs desc - - let object_field sub { - pof_desc; - pof_loc; - pof_attributes; - } = - let loc = sub.location sub pof_loc in - let attrs = sub.attributes sub pof_attributes in - let desc = match pof_desc with - | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t) - | Oinherit t -> Oinherit (sub.typ sub t) - in - Of.mk ~loc ~attrs desc - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs - (List.map (map_loc sub) sl) (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - let loc = sub.location sub ptype_loc in - let attrs = sub.attributes sub ptype_attributes in - Type.mk ~loc ~attrs (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_loc; - ptyext_attributes} = - let loc = sub.location sub ptyext_loc in - let attrs = sub.attributes sub ptyext_attributes in - Te.mk ~loc ~attrs - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - - let map_type_exception sub - {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = - let loc = sub.location sub ptyexn_loc in - let attrs = sub.attributes sub ptyexn_attributes in - Te.mk_exception ~loc ~attrs - (sub.extension_constructor sub ptyexn_constructor) - - let map_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - let loc = sub.location sub pext_loc in - let attrs = sub.attributes sub pext_attributes in - Te.constructor ~loc ~attrs - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - - end - - module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (o, ct) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) - end - - let map_functor_param sub = function - | Unit -> Unit - | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt) - - module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (param, mt) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_type sub mt) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> - type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typesubst l -> - type_subst ~loc (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) - end - - - module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (param, body) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - let attrs = sub.attributes sub attrs in - eval ~loc ~attrs (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_declaration sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) - end - - module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x) - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> - send ~loc ~attrs (sub.expr sub e) (map_loc sub s) - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (o, e) -> - open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e) - | Pexp_letop {let_; ands; body} -> - letop ~loc ~attrs (sub.binding_op sub let_) - (List.map (sub.binding_op sub) ands) (sub.expr sub body) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () - - let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = - let open Exp in - let op = map_loc sub pbop_op in - let pat = sub.pat sub pbop_pat in - let exp = sub.expr sub pbop_exp in - let loc = sub.location sub pbop_loc in - binding_op op pat exp loc - - end - - module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs (sub.constant sub c) - | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) - end - - module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (o, ce) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> - inherit_ ~loc ~attrs o (sub.class_expr sub ce) - (map_opt (map_loc sub) s) - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - let loc = sub.location sub pci_loc in - let attrs = sub.attributes sub pci_attributes in - Ci.mk ~loc ~attrs - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) - end - - (* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - - let default_mapper = - { - constant = C.map; - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - type_exception = T.map_type_exception; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - binding_op = E.map_binding_op; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_substitution = - (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> - Ms.mk - (map_loc this pms_name) - (map_loc this pms_manifest) - ~attrs:(this.attributes this pms_attributes) - ~loc:(this.location this pms_loc) - ); - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_declaration = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (this.module_expr this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - open_description = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this a -> - { - attr_name = map_loc this a.attr_name; - attr_payload = this.payload this a.attr_payload; - attr_loc = this.location this a.attr_loc - } - ); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - - let extension_of_error (error : Locations.location_error) : extension = - Locations.extension_of_error - ~mk_pstr:(fun x -> PStr x) - ~mk_extension:(fun x -> Str.extension x) - ~mk_string_constant:(fun x -> Str.eval (Exp.constant (Pconst_string (x, Location.none (* XXX *), None)))) - error - - let attribute_of_warning loc s = - Attr.mk - {loc; txt = "ocaml.ppwarning" } - (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, loc, None)))])) - - include Locations.Helpers_impl - - let cookies = ref String.Map.empty - - let get_cookie k = - try Some (String.Map.find k !cookies) - with Not_found -> None - - let set_cookie k v = - cookies := String.Map.add k v !cookies - - let tool_name_ref = ref "_none_" - - let tool_name () = !tool_name_ref - - - module PpxContext = struct - open Longident - open Asttypes - open Ast_helper - - let lid name = { txt = Lident name; loc = Location.none } - - let make_string s = Exp.constant (Const.string s) - - let make_bool x = - if x - then Exp.construct (lid "true") None - else Exp.construct (lid "false") None - - let rec make_list f lst = - match lst with - | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) - | [] -> - Exp.construct (lid "[]") None - - let make_pair f1 f2 (x1, x2) = - Exp.tuple [f1 x1; f2 x2] - - let make_option f opt = - match opt with - | Some x -> Exp.construct (lid "Some") (Some (f x)) - | None -> Exp.construct (lid "None") None - - let get_cookies () = - lid "cookies", - make_list (make_pair make_string (fun x -> x)) - (String.Map.bindings !cookies) - - let mk fields = - { - attr_name = { txt = "ocaml.ppx.context"; loc = Location.none }; - attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)]; - attr_loc = Location.none - } - - let make ~tool_name () = - let fields = - [ - lid "tool_name", make_string tool_name; - lid "include_dirs", make_list make_string !Clflags.include_dirs; - lid "load_path", make_list make_string (Migrate_parsetree_compiler_functions.get_load_paths ()); - lid "open_modules", make_list make_string !Clflags.open_modules; - lid "for_package", make_option make_string !Clflags.for_package; - lid "debug", make_bool !Clflags.debug; - lid "use_threads", make_bool !Clflags.use_threads; - lid "use_vmthreads", make_bool false; - lid "recursive_types", make_bool !Clflags.recursive_types; - lid "principal", make_bool !Clflags.principal; - lid "transparent_modules", make_bool !Clflags.transparent_modules; - lid "unboxed_types", make_bool (Migrate_parsetree_compiler_functions.get_unboxed_types ()); - get_cookies () - ] - in - mk fields - - let get_fields = function - | PStr [{pstr_desc = Pstr_eval - ({ pexp_desc = Pexp_record (fields, None) }, [])}] -> - fields - | _ -> - raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" - - let restore fields = - let field name payload = - let rec get_string = function - | { pexp_desc = Pexp_constant (Pconst_string (str, _, None)) } -> str - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] string syntax" name - and get_bool pexp = - match pexp with - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, - None)} -> - true - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, - None)} -> - false - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] bool syntax" name - and get_list elem = function - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> - elem exp :: get_list elem rest - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> - [] - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] list syntax" name - and get_pair f1 f2 = function - | {pexp_desc = Pexp_tuple [e1; e2]} -> - (f1 e1, f2 e2) - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] pair syntax" name - and get_option elem = function - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> - Some (elem exp) - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> - None - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] option syntax" name - in - match name with - | "tool_name" -> - tool_name_ref := get_string payload - | "include_dirs" -> - Clflags.include_dirs := get_list get_string payload - | "load_path" -> - Migrate_parsetree_compiler_functions.load_path_init (get_list get_string payload) - | "open_modules" -> - Clflags.open_modules := get_list get_string payload - | "for_package" -> - Clflags.for_package := get_option get_string payload - | "debug" -> - Clflags.debug := get_bool payload - | "use_threads" -> - Clflags.use_threads := get_bool payload - | "use_vmthreads" -> - if get_bool payload then - raise_errorf "Internal error: vmthreads not supported after 4.09.0" - | "recursive_types" -> - Clflags.recursive_types := get_bool payload - | "principal" -> - Clflags.principal := get_bool payload - | "transparent_modules" -> - Clflags.transparent_modules := get_bool payload - | "unboxed_types" -> - Migrate_parsetree_compiler_functions.set_unboxed_types (get_bool payload) - | "cookies" -> - let l = get_list (get_pair get_string (fun x -> x)) payload in - cookies := - List.fold_left - (fun s (k, v) -> String.Map.add k v s) String.Map.empty - l - | _ -> - () - in - List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields - - let update_cookies fields = - let fields = - List.filter - (function ({txt=Lident "cookies"}, _) -> false | _ -> true) - fields - in - fields @ [get_cookies ()] - end - - let ppx_context = PpxContext.make - - let extension_of_exn exn = extension_of_error (Locations.location_error_of_exn exn) - - let apply_lazy ~source ~target mapper = - let implem ast = - let fields, ast = - match ast with - | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.structure mapper ast - with exn -> - [{pstr_desc = Pstr_extension (extension_of_exn exn, []); - pstr_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Str.attribute (PpxContext.mk fields) :: ast - in - let iface ast = - let fields, ast = - match ast with - | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x; - attr_loc = _})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.signature mapper ast - with exn -> - [{psig_desc = Psig_extension (extension_of_exn exn, []); - psig_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Sig.attribute (PpxContext.mk fields) :: ast - in - - let ic = open_in_bin source in - let magic = - really_input_string ic (String.length Config.ast_impl_magic_number) - in - - let rewrite transform = - Location.input_name := input_value ic; - let ast = input_value ic in - close_in ic; - let ast = transform ast in - let oc = open_out_bin target in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc - and fail () = - close_in ic; - failwith "Ast_mapper: OCaml version mismatch or malformed input"; - in - - if magic = Config.ast_impl_magic_number then - rewrite (implem : structure -> structure) - else if magic = Config.ast_intf_magic_number then - rewrite (iface : signature -> signature) - else fail () - - let drop_ppx_context_str ~restore = function - | {pstr_desc = Pstr_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - - let drop_ppx_context_sig ~restore = function - | {psig_desc = Psig_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - - let add_ppx_context_str ~tool_name ast = - Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast - - let add_ppx_context_sig ~tool_name ast = - Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast - - - let apply ~source ~target mapper = - apply_lazy ~source ~target (fun () -> mapper) - - let run_main mapper = - try - let a = Sys.argv in - let n = Array.length a in - if n > 2 then - let mapper () = - try mapper (Array.to_list (Array.sub a 1 (n - 3))) - with exn -> - (* PR#6463 *) - let f _ _ = raise exn in - {default_mapper with structure = f; signature = f} - in - apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper - else begin - Printf.eprintf "Usage: %s [extra_args] \n%!" - Sys.executable_name; - exit 2 - end - with exn -> - prerr_endline (Printexc.to_string exn); - exit 2 - - let register_function = ref (fun _name f -> run_main f) - let register name f = !register_function name f + type variance (*IF_CURRENT = Asttypes.variance *) = + | Covariant + | Contravariant + | Invariant end module Type_immediacy = struct @@ -4063,120 +208,3 @@ module Outcometree = struct | Ophr_signature of (out_sig_item * out_value option) list | Ophr_exception of (exn * out_value) end - -module Config = struct - let ast_impl_magic_number = "Caml1999M028" - let ast_intf_magic_number = "Caml1999N028" -end - -let map_signature mapper = mapper.Ast_mapper.signature mapper -let map_structure mapper = mapper.Ast_mapper.structure mapper - -let shallow_identity = - let id _ x = x in - { - Ast_mapper. - structure = id; - structure_item = id; - module_expr = id; - signature = id; - signature_item = id; - module_type = id; - with_constraint = id; - class_declaration = id; - class_expr = id; - class_field = id; - class_structure = id; - class_type = id; - class_type_field = id; - class_signature = id; - class_type_declaration = id; - class_description = id; - type_declaration = id; - type_kind = id; - typ = id; - type_extension = id; - extension_constructor = id; - value_description = id; - pat = id; - expr = id; - module_declaration = id; - module_type_declaration = id; - module_binding = id; - open_description = id; - include_description = id; - include_declaration = id; - value_binding = id; - constructor_declaration = id; - label_declaration = id; - cases = id; - case = id; - location = id; - extension = id; - attribute = id; - attributes = id; - payload = id; - binding_op = id; - module_substitution = id; - open_declaration = id; - type_exception = id; - constant = id; - } - -let failing_mapper = - let fail _ _ = - invalid_arg "failing_mapper: this mapper function should never get called" - in - { - Ast_mapper. - structure = fail; - structure_item = fail; - module_expr = fail; - signature = fail; - signature_item = fail; - module_type = fail; - with_constraint = fail; - class_declaration = fail; - class_expr = fail; - class_field = fail; - class_structure = fail; - class_type = fail; - class_type_field = fail; - class_signature = fail; - class_type_declaration = fail; - class_description = fail; - type_declaration = fail; - type_kind = fail; - typ = fail; - type_extension = fail; - extension_constructor = fail; - value_description = fail; - pat = fail; - expr = fail; - module_declaration = fail; - module_type_declaration = fail; - module_binding = fail; - open_description = fail; - include_description = fail; - include_declaration = fail; - value_binding = fail; - constructor_declaration = fail; - label_declaration = fail; - cases = fail; - case = fail; - location = fail; - extension = fail; - attribute = fail; - attributes = fail; - payload = fail; - binding_op = fail; - module_substitution = fail; - open_declaration = fail; - type_exception = fail; - constant = fail; - } - -let make_top_mapper ~signature ~structure = - {failing_mapper with Ast_mapper. - signature = (fun _ x -> signature x); - structure = (fun _ x -> structure x) } diff --git a/src/vendored-omp/src/ast_412.ml b/src/vendored-omp/src/ast_412.ml index 2be503080..666ba3985 100644 --- a/src/vendored-omp/src/ast_412.ml +++ b/src/vendored-omp/src/ast_412.ml @@ -17,3924 +17,53 @@ (* *) (**************************************************************************) -open Ast_409_helper - -module Asttypes = struct - type constant (*IF_CURRENT = Asttypes.constant *) = - Const_int of int - | Const_char of char - | Const_string of string * Location.t * string option - | Const_float of string - | Const_int32 of int32 - | Const_int64 of int64 - | Const_nativeint of nativeint - - type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive - - type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto - - (* Order matters, used in polymorphic comparison *) - type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - - type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - - type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - - type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh - - type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open - - type label = string - - type arg_label (*IF_CURRENT = Asttypes.arg_label *) = - Nolabel - | Labelled of string (* label:T -> ... *) - | Optional of string (* ?label:T -> ... *) - - type 'a loc = 'a Location.loc = { - txt : 'a; - loc : Location.t; - } - - type variance (*IF_CURRENT = Asttypes.variance *) = - | Covariant - | Contravariant - | NoVariance - - type injectivity (*IF_CURRENT = Asttypes.injectivity *) = - | Injective - | NoInjectivity -end - -module Parsetree = struct - open Asttypes - - type constant (*IF_CURRENT = Parsetree.constant *) = - Pconst_integer of string * char option - (* 3 3l 3L 3n - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker - *) - | Pconst_char of char - (* 'c' *) - | Pconst_string of string * Location.t * string option - (* "constant" - {delim|other constant|delim} - - The location span the content of the string, without the delimiters. - *) - | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - - type location_stack = Location.t list - - (** {1 Extension points} *) - - type attribute (*IF_CURRENT = Parsetree.attribute *) = { - attr_name : string loc; - attr_payload : payload; - attr_loc : Location.t; - } - (* [@id ARG] - [@@id ARG] - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - - and extension = string loc * payload - (* [%id ARG] - [%%id ARG] - - Sub-language placeholder -- rejected by the typechecker. - *) - - and attributes = attribute list - - and payload (*IF_CURRENT = Parsetree.payload *) = - | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - - (** {1 Core language} *) - - (* Type expressions *) - - and core_type (*IF_CURRENT = Parsetree.core_type *) = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_loc_stack: location_stack; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional - *) - | Ptyp_tuple of core_type list - (* T1 * ... * Tn - - Invariant: n >= 2 - *) - | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of object_field list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). - - - As the core_type of a Pctf_method node. - - - As the core_type of a Pexp_poly node. - - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) - - and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) - - and row_field (*IF_CURRENT = Parsetree.row_field *) = { - prf_desc : row_field_desc; - prf_loc : Location.t; - prf_attributes : attributes; - } - - and row_field_desc (*IF_CURRENT = Parsetree.row_field_desc *) = - | Rtag of label loc * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 'bool' field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - *) - | Rinherit of core_type - (* [ T ] *) - - and object_field (*IF_CURRENT = Parsetree.object_field *) = { - pof_desc : object_field_desc; - pof_loc : Location.t; - pof_attributes : attributes; - } - - and object_field_desc (*IF_CURRENT = Parsetree.object_field_desc *) = - | Otag of label loc * core_type - | Oinherit of core_type - - (* Patterns *) - - and pattern (*IF_CURRENT = Parsetree.pattern *) = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_loc_stack: location_stack; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Ppat_interval of constant * constant - (* 'a'..'z' - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (* (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Ppat_construct of Longident.t loc * pattern option - (* C None - C P Some P - C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) - *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) - | Ppat_unpack of string option loc - (* (module P) Some "P" - (module _) None - - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of Longident.t loc * pattern - (* M.(P) *) - - (* Value expressions *) - - and expression (*IF_CURRENT = Parsetree.expression *) = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_loc_stack: location_stack; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = - | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) - | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_tuple of expression list - (* (E1, ..., En) - - Invariant: n >= 2 - *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) - | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) - | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * label loc - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of label loc * expression - (* x <- 2 *) - | Pexp_override of (label loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) - | Pexp_letmodule of string option loc * module_expr * expression - (* let module M = ME in E *) - | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) - | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) - | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string loc * expression - (* fun (type t) -> E *) - | Pexp_pack of module_expr - (* (module ME) - - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of open_declaration * expression - (* M.(E) - let open M in E - let! open M in E *) - | Pexp_letop of letop - (* let* P = E in E - let* P = E and* P = E in E *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable - (* . *) - - and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - - and letop (*IF_CURRENT = Parsetree.letop *) = - { - let_ : binding_op; - ands : binding_op list; - body : expression; - } - - and binding_op (*IF_CURRENT = Parsetree.binding_op *) = - { - pbop_op : string loc; - pbop_pat : pattern; - pbop_exp : expression; - pbop_loc : Location.t; - } - - (* Value descriptions *) - - and value_description (*IF_CURRENT = Parsetree.value_description *) = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } - -(* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) -*) - - (* Type declarations *) - - and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = - { - ptype_name: string loc; - ptype_params: (core_type * (variance * injectivity)) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } - -(* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) -*) - - and type_kind (*IF_CURRENT = Parsetree.type_kind *) = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) - | Ptype_open - - and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l : T [@id1] [@id2] *) - } - - (* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. - *) - - and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = - { - pcd_name: string loc; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - -(* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) -*) - - and type_extension (*IF_CURRENT = Parsetree.type_extension *) = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * (variance * injectivity)) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_loc: Location.t; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } -(* - type t += ... -*) - - and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - (* exception E *) - and type_exception (*IF_CURRENT = Parsetree.type_exception *) = - { - ptyexn_constructor: extension_constructor; - ptyexn_loc: Location.t; - ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = - Pext_decl of constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([T1; ...; Tn], None) - | C: T0 ([], Some T0) - | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) - *) - | Pext_rebind of Longident.t loc - (* - | C = D - *) - - (** {1 Class language} *) - - (* Type expressions for the class language *) - - and class_type (*IF_CURRENT = Parsetree.class_type *) = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = - | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) - | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - | Pcty_open of open_description * class_type - (* let open M in CT *) - - and class_signature (*IF_CURRENT = Parsetree.class_signature *) = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } - (* object('selfpat) ... end - object ... end (self = Ptyp_any) - *) - - and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = - | Pctf_inherit of class_type - (* inherit CT *) - | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) - - and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = - { - pci_virt: virtual_flag; - pci_params: (core_type * (variance * injectivity)) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... - - Also used for "class type" declaration. - *) - - and class_description = class_type class_infos - - and class_type_declaration = class_type class_infos - - (* Value expressions for the class language *) - - and class_expr (*IF_CURRENT = Parsetree.class_expr *) = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = - | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - | Pcl_open of open_description * class_expr - (* let open M in CE *) - - - and class_structure (*IF_CURRENT = Parsetree.class_structure *) = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } - (* object(selfpat) ... end - object ... end (self = Ppat_any) - *) - - and class_field (*IF_CURRENT = Parsetree.class_field *) = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_field_desc (*IF_CURRENT = Parsetree.class_field_desc *) = - | Pcf_inherit of override_flag * class_expr * string loc option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) - | Pcf_val of (label loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) - | Pcf_method of (label loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) - - and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - - and class_declaration = class_expr class_infos - - (** {1 Module language} *) - - (* Type expressions for the module language *) - - and module_type (*IF_CURRENT = Parsetree.module_type *) = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) - | Pmty_functor of functor_parameter * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) - - and functor_parameter (*IF_CURRENT = Parsetree.functor_parameter *) = - | Unit - (* () *) - | Named of string option loc * module_type - (* (X : MT) Some X, MT - (_ : MT) None, MT *) - - and signature = signature_item list - - and signature_item (*IF_CURRENT = Parsetree.signature_item *) = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - - and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = - | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) - | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typesubst of type_declaration list - (* type t1 := ... and ... and tn := ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of type_exception - (* exception C of T *) - | Psig_module of module_declaration - (* module X = M - module X : MT *) - | Psig_modsubst of module_substitution - (* module X := M *) - | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) - | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) - | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) - - and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = - { - pmd_name: string option loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } - (* S : MT *) - - and module_substitution (*IF_CURRENT = Parsetree.module_substitution *) = - { - pms_name: string loc; - pms_manifest: Longident.t loc; - pms_attributes: attributes; (* ... [@@id1] [@@id2] *) - pms_loc: Location.t; - } - - and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } - (* S = MT - S (abstract module type declaration, pmtd_type = None) - *) - - and 'a open_infos (*IF_CURRENT = 'a Parsetree.open_infos *) = - { - popen_expr: 'a; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } - (* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) - - and open_description = Longident.t loc open_infos - (* open M.N - open M(N).O *) - - and open_declaration = module_expr open_infos - (* open M.N - open M(N).O - open struct ... end *) - - and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - - and include_description = module_type include_infos - (* include MT *) - - and include_declaration = module_expr include_infos - (* include ME *) - - and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = - | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) - | Pwith_typesubst of Longident.t loc * type_declaration - (* with type X.t := ..., same format as [Pwith_type] *) - | Pwith_modsubst of Longident.t loc * Longident.t loc - (* with module X.Y := Z *) - - (* Value expressions for the module language *) - - and module_expr (*IF_CURRENT = Parsetree.module_expr *) = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) - | Pmod_functor of functor_parameter * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) - - and structure = structure_item list - - and structure_item (*IF_CURRENT = Parsetree.structure_item *) = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - - and structure_item_desc (*IF_CURRENT = Parsetree.structure_item_desc *) = - | Pstr_eval of expression * attributes - (* E *) - | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) - | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) - | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) - | Pstr_exception of type_exception - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) - | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_declaration - (* open X *) - | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) - | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) - - and value_binding (*IF_CURRENT = Parsetree.value_binding *) = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - - and module_binding (*IF_CURRENT = Parsetree.module_binding *) = - { - pmb_name: string option loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } - (* X = ME *) - - (** {1 Toplevel} *) - - (* Toplevel phrases *) - - type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = - | Ptop_def of structure - | Ptop_dir of toplevel_directive - (* #use, #load ... *) - - and toplevel_directive (*IF_CURRENT = Parsetree.toplevel_directive *) = - { - pdir_name : string loc; - pdir_arg : directive_argument option; - pdir_loc : Location.t; - } - - and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = - { - pdira_desc : directive_argument_desc; - pdira_loc : Location.t; - } - - and directive_argument_desc (*IF_CURRENT = Parsetree.directive_argument_desc *) = - | Pdir_string of string - | Pdir_int of string * char option - | Pdir_ident of Longident.t - | Pdir_bool of bool -end - -module Docstrings: sig - -(** (Re)Initialise all docstring state *) -val init : unit -> unit - -(** Emit warnings for unattached and ambiguous docstrings *) -val warn_bad_docstrings : unit -> unit - -(** {2 Docstrings} *) - -(** Documentation comments *) -type docstring - -(** Create a docstring *) -val docstring : string -> Location.t -> docstring - -(** Register a docstring *) -val register : docstring -> unit - -(** Get the text of a docstring *) -val docstring_body : docstring -> string - -(** Get the location of a docstring *) -val docstring_loc : docstring -> Location.t - -(** {2 Set functions} - These functions are used by the lexer to associate docstrings to - the locations of tokens. *) - -(** Docstrings immediately preceding a token *) -val set_pre_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following a token *) -val set_post_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings not immediately adjacent to a token *) -val set_floating_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following the token which precedes this one *) -val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately preceding the token which follows this one *) -val set_post_extra_docstrings : Lexing.position -> docstring list -> unit - -(** {2 Items} - The {!docs} type represents documentation attached to an item. *) - -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - -val empty_docs : docs - -val docs_attr : docstring -> Parsetree.attribute - -(** Convert item documentation to attributes and add them to an - attribute list *) -val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) -val symbol_docs : unit -> docs -val symbol_docs_lazy : unit -> docs Lazy.t - -(** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) -val rhs_docs : int -> int -> docs -val rhs_docs_lazy : int -> int -> docs Lazy.t - -(** Mark the item documentation for the current symbol (for ambiguity - warnings). *) -val mark_symbol_docs : unit -> unit - -(** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) -val mark_rhs_docs : int -> int -> unit - -(** {2 Fields and constructors} - The {!info} type represents documentation attached to a field or - constructor. *) - -type info = docstring option - -val empty_info : info - -val info_attr : docstring -> Parsetree.attribute - -(** Convert field info to attributes and add them to an - attribute list *) -val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the field info for the current symbol. *) -val symbol_info : unit -> info - -(** Fetch the field info following the symbol at a given position. *) -val rhs_info : int -> info - -(** {2 Unattached comments} - The {!text} type represents documentation which is not attached to - anything. *) - -type text = docstring list - -val empty_text : text -val empty_text_lazy : text Lazy.t - -val text_attr : docstring -> Parsetree.attribute - -(** Convert text to attributes and add them to an attribute list *) -val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the text preceding the current symbol. *) -val symbol_text : unit -> text -val symbol_text_lazy : unit -> text Lazy.t - -(** Fetch the text preceding the symbol at the given position. *) -val rhs_text : int -> text -val rhs_text_lazy : int -> text Lazy.t - -(** {2 Extra text} - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - -(** Fetch additional text preceding the current symbol *) -val symbol_pre_extra_text : unit -> text - -(** Fetch additional text following the current symbol *) -val symbol_post_extra_text : unit -> text - -(** Fetch additional text preceding the symbol at the given position *) -val rhs_pre_extra_text : int -> text - -(** Fetch additional text following the symbol at the given position *) -val rhs_post_extra_text : int -> text - -(** Fetch text following the symbol at the given position *) -val rhs_post_text : int -> text - -module WithMenhir: sig -(** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) -val symbol_docs : Lexing.position * Lexing.position -> docs -val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t - -(** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) -val rhs_docs : Lexing.position -> Lexing.position -> docs -val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t - -(** Mark the item documentation for the current symbol (for ambiguity - warnings). *) -val mark_symbol_docs : Lexing.position * Lexing.position -> unit - -(** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) -val mark_rhs_docs : Lexing.position -> Lexing.position -> unit - -(** Fetch the field info for the current symbol. *) -val symbol_info : Lexing.position -> info - -(** Fetch the field info following the symbol at a given position. *) -val rhs_info : Lexing.position -> info - -(** Fetch the text preceding the current symbol. *) -val symbol_text : Lexing.position -> text -val symbol_text_lazy : Lexing.position -> text Lazy.t - -(** Fetch the text preceding the symbol at the given position. *) -val rhs_text : Lexing.position -> text -val rhs_text_lazy : Lexing.position -> text Lazy.t - -(** {3 Extra text} - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - -(** Fetch additional text preceding the current symbol *) -val symbol_pre_extra_text : Lexing.position -> text - -(** Fetch additional text following the current symbol *) -val symbol_post_extra_text : Lexing.position -> text - -(** Fetch additional text preceding the symbol at the given position *) -val rhs_pre_extra_text : Lexing.position -> text - -(** Fetch additional text following the symbol at the given position *) -val rhs_post_extra_text : Lexing.position -> text - -(** Fetch text following the symbol at the given position *) -val rhs_post_text : Lexing.position -> text - -end - -end = struct -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Leo White *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -open Location - -(* Docstrings *) - -(* A docstring is "attached" if it has been inserted in the AST. This - is used for generating unexpected docstring warnings. *) -type ds_attached = - | Unattached (* Not yet attached anything.*) - | Info (* Attached to a field or constructor. *) - | Docs (* Attached to an item or as floating text. *) - -(* A docstring is "associated" with an item if there are no blank lines between - them. This is used for generating docstring ambiguity warnings. *) -type ds_associated = - | Zero (* Not associated with an item *) - | One (* Associated with one item *) - | Many (* Associated with multiple items (ambiguity) *) - -type docstring = - { ds_body: string; - ds_loc: Location.t; - mutable ds_attached: ds_attached; - mutable ds_associated: ds_associated; } - -(* List of docstrings *) - -let docstrings : docstring list ref = ref [] - -(* Warn for unused and ambiguous docstrings *) - -let warn_bad_docstrings () = - if Warnings.is_active (Migrate_parsetree_compiler_functions.bad_docstring true) then begin - List.iter - (fun ds -> - match ds.ds_attached with - | Info -> () - | Unattached -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring true) - | Docs -> - match ds.ds_associated with - | Zero | One -> () - | Many -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring false)) - (List.rev !docstrings) - end - -(* Docstring constructors and destructors *) - -let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; - ds_attached = Unattached; - ds_associated = Zero; } - in - ds - -let register ds = - docstrings := ds :: !docstrings - -let docstring_body ds = ds.ds_body - -let docstring_loc ds = ds.ds_loc - -(* Docstrings attached to items *) - -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - -let empty_docs = { docs_pre = None; docs_post = None } - -let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - -let docs_attr ds = - let open Parsetree in - let body = ds.ds_body in - let loc = ds.ds_loc in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } - in - { attr_name = doc_loc; - attr_payload = PStr [item]; - attr_loc = loc } - -let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - -(* Docstrings attached to constructors or fields *) - -type info = docstring option - -let empty_info = None - -let info_attr = docs_attr - -let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - -(* Docstrings not attached to a specific item *) - -type text = docstring list - -let empty_text = [] -let empty_text_lazy = lazy [] - -let text_loc = {txt = "ocaml.text"; loc = Location.none} - -let text_attr ds = - let open Parsetree in - let body = ds.ds_body in - let loc = ds.ds_loc in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } - in - { attr_name = text_loc; - attr_payload = PStr [item]; - attr_loc = loc } - -let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - -(* Find the first non-info docstring in a list, attach it and return it *) -let get_docstring ~info dsl = - let rec loop = function - | [] -> None - | {ds_attached = Info; _} :: rest -> loop rest - | ds :: _ -> - ds.ds_attached <- if info then Info else Docs; - Some ds - in - loop dsl - -(* Find all the non-info docstrings in a list, attach them and return them *) -let get_docstrings dsl = - let rec loop acc = function - | [] -> List.rev acc - | {ds_attached = Info; _} :: rest -> loop acc rest - | ds :: rest -> - ds.ds_attached <- Docs; - loop (ds :: acc) rest - in - loop [] dsl - -(* "Associate" all the docstrings in a list *) -let associate_docstrings dsl = - List.iter - (fun ds -> - match ds.ds_associated with - | Zero -> ds.ds_associated <- One - | (One | Many) -> ds.ds_associated <- Many) - dsl - -(* Map from positions to pre docstrings *) - -let pre_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_pre_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_table pos dsl - -let get_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - -let mark_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl - with Not_found -> () - -(* Map from positions to post docstrings *) - -let post_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_post_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_table pos dsl - -let get_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - -let mark_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl - with Not_found -> () - -let get_info pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstring ~info:true dsl - with Not_found -> None - -(* Map from positions to floating docstrings *) - -let floating_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_floating_docstrings pos dsl = - if dsl <> [] then Hashtbl.add floating_table pos dsl - -let get_text pos = - try - let dsl = Hashtbl.find floating_table pos in - get_docstrings dsl - with Not_found -> [] - -let get_post_text pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstrings dsl - with Not_found -> [] - -(* Maps from positions to extra docstrings *) - -let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_pre_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_extra_table pos dsl - -let get_pre_extra_text pos = - try - let dsl = Hashtbl.find pre_extra_table pos in - get_docstrings dsl - with Not_found -> [] - -let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_post_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_extra_table pos dsl - -let get_post_extra_text pos = - try - let dsl = Hashtbl.find post_extra_table pos in - get_docstrings dsl - with Not_found -> [] - -(* Docstrings from parser actions *) -module WithParsing = struct -let symbol_docs () = - { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); - docs_post = get_post_docs (Parsing.symbol_end_pos ()); } - -let symbol_docs_lazy () = - let p1 = Parsing.symbol_start_pos () in - let p2 = Parsing.symbol_end_pos () in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); - docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } - -let rhs_docs_lazy pos1 pos2 = - let p1 = Parsing.rhs_start_pos pos1 in - let p2 = Parsing.rhs_end_pos pos2 in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let mark_symbol_docs () = - mark_pre_docs (Parsing.symbol_start_pos ()); - mark_post_docs (Parsing.symbol_end_pos ()) - -let mark_rhs_docs pos1 pos2 = - mark_pre_docs (Parsing.rhs_start_pos pos1); - mark_post_docs (Parsing.rhs_end_pos pos2) - -let symbol_info () = - get_info (Parsing.symbol_end_pos ()) - -let rhs_info pos = - get_info (Parsing.rhs_end_pos pos) - -let symbol_text () = - get_text (Parsing.symbol_start_pos ()) - -let symbol_text_lazy () = - let pos = Parsing.symbol_start_pos () in - lazy (get_text pos) - -let rhs_text pos = - get_text (Parsing.rhs_start_pos pos) - -let rhs_post_text pos = - get_post_text (Parsing.rhs_end_pos pos) - -let rhs_text_lazy pos = - let pos = Parsing.rhs_start_pos pos in - lazy (get_text pos) - -let symbol_pre_extra_text () = - get_pre_extra_text (Parsing.symbol_start_pos ()) - -let symbol_post_extra_text () = - get_post_extra_text (Parsing.symbol_end_pos ()) - -let rhs_pre_extra_text pos = - get_pre_extra_text (Parsing.rhs_start_pos pos) - -let rhs_post_extra_text pos = - get_post_extra_text (Parsing.rhs_end_pos pos) -end - -include WithParsing - -module WithMenhir = struct -let symbol_docs (startpos, endpos) = - { docs_pre = get_pre_docs startpos; - docs_post = get_post_docs endpos; } - -let symbol_docs_lazy (p1, p2) = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs pos1; - docs_post = get_post_docs pos2; } - -let rhs_docs_lazy p1 p2 = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let mark_symbol_docs (startpos, endpos) = - mark_pre_docs startpos; - mark_post_docs endpos; - () - -let mark_rhs_docs pos1 pos2 = - mark_pre_docs pos1; - mark_post_docs pos2; - () - -let symbol_info endpos = - get_info endpos - -let rhs_info endpos = - get_info endpos - -let symbol_text startpos = - get_text startpos - -let symbol_text_lazy startpos = - lazy (get_text startpos) - -let rhs_text pos = - get_text pos - -let rhs_post_text pos = - get_post_text pos - -let rhs_text_lazy pos = - lazy (get_text pos) - -let symbol_pre_extra_text startpos = - get_pre_extra_text startpos - -let symbol_post_extra_text endpos = - get_post_extra_text endpos - -let rhs_pre_extra_text pos = - get_pre_extra_text pos - -let rhs_post_extra_text pos = - get_post_extra_text pos -end - -(* (Re)Initialise all comment state *) - -let init () = - docstrings := []; - Hashtbl.reset pre_table; - Hashtbl.reset post_table; - Hashtbl.reset floating_table; - Hashtbl.reset pre_extra_table; - Hashtbl.reset post_extra_table -end - - -module Ast_helper: sig -open Asttypes -open Docstrings -open Parsetree - -type 'a with_loc = 'a Location.loc -type loc = Location.t - -type lid = Longident.t with_loc -type str = string with_loc -type str_opt = string option with_loc -type attrs = attribute list - -(** {1 Default locations} *) - -val default_loc: loc ref - (** Default value for all optional location arguments. *) - -val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - -(** {1 Constants} *) - -module Const : sig - val char : char -> constant - val string : - ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant -end - -(** {1 Attributes} *) -module Attr : sig - val mk: ?loc:loc -> str -> payload -> attribute -end - -(** {1 Core language} *) - -(** Type expressions *) -module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - -(** Patterns *) -module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - -(** Expressions *) -module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr - -> expression -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression - -> expression - val letop: ?loc:loc -> ?attrs:attrs -> binding_op - -> binding_op list -> expression -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - val binding_op: str -> pattern -> expression -> loc -> binding_op - end - -(** Value declarations *) -module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - -(** Type declarations *) -module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * (variance * injectivity)) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - -(** Type extensions *) -module Te: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * (variance * injectivity)) list -> - ?priv:private_flag -> lid -> extension_constructor list -> type_extension - - val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - extension_constructor -> type_exception - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - -(** {1 Module language} *) - -(** Module type expressions *) -module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - -(** Module expressions *) -module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - -(** Signature items *) -module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_subst: ?loc:loc -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> type_exception -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val mod_subst: ?loc:loc -> module_substitution -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - -(** Structure items *) -module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> type_exception -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_declaration -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - -(** Module declarations *) -module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_type -> module_declaration - end - -(** Module substitutions *) -module Ms: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> lid -> module_substitution - end - -(** Module type declarations *) -module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - -(** Module bindings *) -module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_expr -> module_binding - end - -(** Opens *) -module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> 'a -> 'a open_infos - end - -(** Includes *) -module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - -(** Value bindings *) -module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - -(** {1 Class language} *) - -(** Class type expressions *) -module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type - -> class_type - end - -(** Class type fields *) -module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - -(** Class expressions *) -module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr - -> class_expr - end - -(** Class fields *) -module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - -(** Classes *) -module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> - ?params:(core_type * (variance * injectivity)) list -> - str -> 'a -> 'a class_infos - end - -(** Class signatures *) -module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - -(** Class structures *) -module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - -(** Row fields *) -module Rf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> bool -> core_type list -> row_field - val inherit_: ?loc:loc -> core_type -> row_field - end - -(** Object fields *) -module Of: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - object_field_desc -> object_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> core_type -> object_field - val inherit_: ?loc:loc -> core_type -> object_field - end - -end = struct - -open Asttypes -open Parsetree -open Docstrings - -type 'a with_loc = 'a Location.loc -type loc = Location.t - -type lid = Longident.t with_loc -type str = string with_loc -type str_opt = string option with_loc -type attrs = attribute list - -let default_loc = ref Location.none - -let with_default_loc l f = - Misc.protect_refs [Misc.R (default_loc, l)] f - -module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (string_of_int i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter ?(loc= !default_loc) s = - Pconst_string (s, loc, quotation_delimiter) -end - -module Attr = struct - let mk ?(loc= !default_loc) name payload = - { attr_name = name; - attr_payload = payload; - attr_loc = loc } -end - -module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; - ptyp_loc = loc; - ptyp_loc_stack = []; - ptyp_attributes = attrs} - - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - - let varify_constructors var_names t = - let check_variable vl loc v = - if List.mem v vl then - raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in - let var_names = List.map (fun v -> v.txt) var_names in - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> - check_variable var_names t.ptyp_loc x; - Ptyp_var x - | Ptyp_arrow (label,core_type,core_type') -> - Ptyp_arrow(label, loop core_type, loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr( { txt = Longident.Lident s }, []) - when List.mem s var_names -> - Ptyp_var s - | Ptyp_constr(longident, lst) -> - Ptyp_constr(longident, List.map loop lst) - | Ptyp_object (lst, o) -> - Ptyp_object (List.map loop_object_field lst, o) - | Ptyp_class (longident, lst) -> - Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) - in - {t with ptyp_desc = desc} - and loop_row_field field = - let prf_desc = match field.prf_desc with - | Rtag(label,flag,lst) -> - Rtag(label,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - in - { field with prf_desc; } - and loop_object_field field = - let pof_desc = match field.pof_desc with - | Otag(label, t) -> - Otag(label, loop t) - | Oinherit t -> - Oinherit (loop t) - in - { field with pof_desc; } - in - loop t - -end - -module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; - ppat_loc = loc; - ppat_loc_stack = []; - ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) -end - -module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b)) - let letop ?loc ?attrs let_ ands body = - mk ?loc ?attrs (Pexp_letop {let_; ands; body}) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - - let binding_op op pat exp loc = - { - pbop_op = op; - pbop_pat = pat; - pbop_exp = exp; - pbop_loc = loc; - } -end - -module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) -end - -module Mod = struct -let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg body = - mk ?loc ?attrs (Pmod_functor (arg, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) -end - -module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_subst ?loc a = mk ?loc (Psig_typesubst a) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let mod_subst ?loc a = mk ?loc (Psig_modsubst a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt -end - -module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt -end - -module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b)) -end - -module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b)) -end - -module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - -end - -module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - -end - -module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } -end - -module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } -end - -module Ms = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name syn = - { - pms_name = name; - pms_manifest = syn; - pms_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pms_loc = loc; - } -end - -module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } -end - -module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } -end - -module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) expr = - { - popen_expr = expr; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } -end - -module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - -end - -module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } -end - -module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } -end - -module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } +module Asttypes = struct + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * Location.t * string option + | Const_float of string + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint -end + type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive -(** Type extensions *) -module Te = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_loc = loc; - ptyext_attributes = add_docs_attrs docs attrs; - } + type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto - let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - constructor = - { - ptyexn_constructor = constructor; - ptyexn_loc = loc; - ptyexn_attributes = add_docs_attrs docs attrs; - } + (* Order matters, used in polymorphic comparison *) + type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } + type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } + type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } + type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh -end + type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open -module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } -end + type label = string -module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } -end + type arg_label (*IF_CURRENT = Asttypes.arg_label *) = + Nolabel + | Labelled of string (* label:T -> ... *) + | Optional of string (* ?label:T -> ... *) -(** Row fields *) -module Rf = struct - let mk ?(loc = !default_loc) ?(attrs = []) desc = { - prf_desc = desc; - prf_loc = loc; - prf_attributes = attrs; + type 'a loc = 'a Location.loc = { + txt : 'a; + loc : Location.t; } - let tag ?loc ?attrs label const tys = - mk ?loc ?attrs (Rtag (label, const, tys)) - let inherit_?loc ty = - mk ?loc (Rinherit ty) -end -(** Object fields *) -module Of = struct - let mk ?(loc = !default_loc) ?(attrs=[]) desc = { - pof_desc = desc; - pof_loc = loc; - pof_attributes = attrs; - } - let tag ?loc ?attrs label ty = - mk ?loc ?attrs (Otag (label, ty)) - let inherit_ ?loc ty = - mk ?loc (Oinherit ty) -end + type variance (*IF_CURRENT = Asttypes.variance *) = + | Covariant + | Contravariant + | NoVariance + type injectivity (*IF_CURRENT = Asttypes.injectivity *) = + | Injective + | NoInjectivity end -module Ast_mapper: sig -open Parsetree - -(** {1 A generic Parsetree mapper} *) - -type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; -} -(** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - -val default_mapper: mapper -(** A default mapper, which implements a "deep identity" mapping. *) - -(** {1 Apply mappers to compilation units} *) - -val tool_name: unit -> string -(** Can be used within a ppx preprocessor to know which tool is - calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], - ["ocaml"], ... Some global variables that reflect command-line - options are automatically synchronized between the calling tool - and the ppx preprocessor: {!Clflags.include_dirs}, - {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package}, - {!Clflags.debug}. *) - - -val apply: source:string -> target:string -> mapper -> unit -(** Apply a mapper (parametrized by the unit name) to a dumped - parsetree found in the [source] file and put the result in the - [target] file. The [structure] or [signature] field of the mapper - is applied to the implementation or interface. *) - -val run_main: (string list -> mapper) -> unit -(** Entry point to call to implement a standalone -ppx rewriter from a - mapper, parametrized by the command line arguments. The current - unit name can be obtained from {!Location.input_name}. This - function implements proper error reporting for uncaught - exceptions. *) - -(** {1 Registration API} *) - -val register_function: (string -> (string list -> mapper) -> unit) ref - -val register: string -> (string list -> mapper) -> unit -(** Apply the [register_function]. The default behavior is to run the - mapper immediately, taking arguments from the process command - line. This is to support a scenario where a mapper is linked as a - stand-alone executable. - - It is possible to overwrite the [register_function] to define - "-ppx drivers", which combine several mappers in a single process. - Typically, a driver starts by defining [register_function] to a - custom implementation, then lets ppx rewriters (linked statically - or dynamically) register themselves, and then run all or some of - them. It is also possible to have -ppx drivers apply rewriters to - only specific parts of an AST. - - The first argument to [register] is a symbolic name to be used by - the ppx driver. *) - - -(** {1 Convenience functions to write mappers} *) - -val map_opt: ('a -> 'b) -> 'a option -> 'b option - -val extension_of_error: Location.error -> extension -(** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) - -val attribute_of_warning: Location.t -> string -> attribute -(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) - -(** {1 Helper functions to call external mappers} *) - -val add_ppx_context_str: - tool_name:string -> Parsetree.structure -> Parsetree.structure -(** Extract information from the current environment and encode it - into an attribute which is prepended to the list of structure - items in order to pass the information to an external - processor. *) - -val add_ppx_context_sig: - tool_name:string -> Parsetree.signature -> Parsetree.signature -(** Same as [add_ppx_context_str], but for signatures. *) - -val drop_ppx_context_str: - restore:bool -> Parsetree.structure -> Parsetree.structure -(** Drop the ocaml.ppx.context attribute from a structure. If - [restore] is true, also restore the associated data in the current - process. *) - -val drop_ppx_context_sig: - restore:bool -> Parsetree.signature -> Parsetree.signature -(** Same as [drop_ppx_context_str], but for signatures. *) - -(** {1 Cookies} *) - -(** Cookies are used to pass information from a ppx processor to - a further invocation of itself, when called from the OCaml - toplevel (or other tools that support cookies). *) - -val set_cookie: string -> Parsetree.expression -> unit -val get_cookie: string -> Parsetree.expression option - -end = struct - open Parsetree - open Ast_helper - open Location - - module String = Misc.Stdlib.String - - type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - - let map_fst f (x, y) = (f x, y) - let map_snd f (x, y) = (x, f y) - let map_tuple f1 f2 (x, y) = (f1 x, f2 y) - let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) - let map_opt f = function None -> None | Some x -> Some (f x) - - let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - - module C = struct - (* Constants *) - - let map sub c = match c with - | Pconst_integer _ - | Pconst_char _ - | Pconst_float _ - -> c - | Pconst_string (s, loc, quotation_delimiter) -> - let loc = sub.location sub loc in - Const.string ~loc ?quotation_delimiter s - end - - module T = struct - (* Type expressions for the core language *) - - let row_field sub { - prf_desc; - prf_loc; - prf_attributes; - } = - let loc = sub.location sub prf_loc in - let attrs = sub.attributes sub prf_attributes in - let desc = match prf_desc with - | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - in - Rf.mk ~loc ~attrs desc - - let object_field sub { - pof_desc; - pof_loc; - pof_attributes; - } = - let loc = sub.location sub pof_loc in - let attrs = sub.attributes sub pof_attributes in - let desc = match pof_desc with - | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t) - | Oinherit t -> Oinherit (sub.typ sub t) - in - Of.mk ~loc ~attrs desc - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs - (List.map (map_loc sub) sl) (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - let loc = sub.location sub ptype_loc in - let attrs = sub.attributes sub ptype_attributes in - Type.mk ~loc ~attrs (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_loc; - ptyext_attributes} = - let loc = sub.location sub ptyext_loc in - let attrs = sub.attributes sub ptyext_attributes in - Te.mk ~loc ~attrs - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - - let map_type_exception sub - {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = - let loc = sub.location sub ptyexn_loc in - let attrs = sub.attributes sub ptyexn_attributes in - Te.mk_exception ~loc ~attrs - (sub.extension_constructor sub ptyexn_constructor) - - let map_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - let loc = sub.location sub pext_loc in - let attrs = sub.attributes sub pext_attributes in - Te.constructor ~loc ~attrs - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - - end - - module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (o, ct) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) - end - - let map_functor_param sub = function - | Unit -> Unit - | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt) - - module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (param, mt) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_type sub mt) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> - type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typesubst l -> - type_subst ~loc (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) - end - - - module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (param, body) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - let attrs = sub.attributes sub attrs in - eval ~loc ~attrs (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_declaration sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) - end - - module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x) - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> - send ~loc ~attrs (sub.expr sub e) (map_loc sub s) - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (o, e) -> - open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e) - | Pexp_letop {let_; ands; body} -> - letop ~loc ~attrs (sub.binding_op sub let_) - (List.map (sub.binding_op sub) ands) (sub.expr sub body) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () - - let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = - let open Exp in - let op = map_loc sub pbop_op in - let pat = sub.pat sub pbop_pat in - let exp = sub.expr sub pbop_exp in - let loc = sub.location sub pbop_loc in - binding_op op pat exp loc - - end - - module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs (sub.constant sub c) - | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) - end - - module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (o, ce) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> - inherit_ ~loc ~attrs o (sub.class_expr sub ce) - (map_opt (map_loc sub) s) - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - let loc = sub.location sub pci_loc in - let attrs = sub.attributes sub pci_attributes in - Ci.mk ~loc ~attrs - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) - end - - (* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - - let default_mapper = - { - constant = C.map; - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - type_exception = T.map_type_exception; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - binding_op = E.map_binding_op; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_substitution = - (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> - Ms.mk - (map_loc this pms_name) - (map_loc this pms_manifest) - ~attrs:(this.attributes this pms_attributes) - ~loc:(this.location this pms_loc) - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_declaration = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (this.module_expr this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - open_description = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this a -> - { - attr_name = map_loc this a.attr_name; - attr_payload = this.payload this a.attr_payload; - attr_loc = this.location this a.attr_loc - } - ); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - - let extension_of_error error = - Locations.extension_of_error - ~mk_pstr:(fun x -> PStr x) - ~mk_extension:(fun x -> Str.extension x) - ~mk_string_constant:(fun x -> Str.eval (Exp.constant (Pconst_string (x, Location.none (* XXX *), None)))) - error - - let attribute_of_warning loc s = - Attr.mk - {loc; txt = "ocaml.ppwarning" } - (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, loc, None)))])) - - let cookies = ref String.Map.empty - - let get_cookie k = - try Some (String.Map.find k !cookies) - with Not_found -> None - - let set_cookie k v = - cookies := String.Map.add k v !cookies - - let tool_name_ref = ref "_none_" - - let tool_name () = !tool_name_ref - - - module PpxContext = struct - open Longident - open Asttypes - open Ast_helper - - let lid name = { txt = Lident name; loc = Location.none } - - let make_string s = Exp.constant (Const.string s) - - let make_bool x = - if x - then Exp.construct (lid "true") None - else Exp.construct (lid "false") None - - let rec make_list f lst = - match lst with - | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) - | [] -> - Exp.construct (lid "[]") None - - let make_pair f1 f2 (x1, x2) = - Exp.tuple [f1 x1; f2 x2] - - let make_option f opt = - match opt with - | Some x -> Exp.construct (lid "Some") (Some (f x)) - | None -> Exp.construct (lid "None") None - - let get_cookies () = - lid "cookies", - make_list (make_pair make_string (fun x -> x)) - (String.Map.bindings !cookies) - - let mk fields = - { - attr_name = { txt = "ocaml.ppx.context"; loc = Location.none }; - attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)]; - attr_loc = Location.none - } - - let make ~tool_name () = - let fields = - [ - lid "tool_name", make_string tool_name; - lid "include_dirs", make_list make_string !Clflags.include_dirs; - lid "load_path", make_list make_string (Migrate_parsetree_compiler_functions.get_load_paths ()); - lid "open_modules", make_list make_string !Clflags.open_modules; - lid "for_package", make_option make_string !Clflags.for_package; - lid "debug", make_bool !Clflags.debug; - lid "use_threads", make_bool !Clflags.use_threads; - lid "use_vmthreads", make_bool false; - lid "recursive_types", make_bool !Clflags.recursive_types; - lid "principal", make_bool !Clflags.principal; - lid "transparent_modules", make_bool !Clflags.transparent_modules; - lid "unboxed_types", make_bool (Migrate_parsetree_compiler_functions.get_unboxed_types ()); - get_cookies () - ] - in - mk fields - - let get_fields = function - | PStr [{pstr_desc = Pstr_eval - ({ pexp_desc = Pexp_record (fields, None) }, [])}] -> - fields - | _ -> - raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" - - let restore fields = - let field name payload = - let rec get_string = function - | { pexp_desc = Pexp_constant (Pconst_string (str, _, None)) } -> str - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] string syntax" name - and get_bool pexp = - match pexp with - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, - None)} -> - true - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, - None)} -> - false - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] bool syntax" name - and get_list elem = function - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> - elem exp :: get_list elem rest - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> - [] - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] list syntax" name - and get_pair f1 f2 = function - | {pexp_desc = Pexp_tuple [e1; e2]} -> - (f1 e1, f2 e2) - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] pair syntax" name - and get_option elem = function - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> - Some (elem exp) - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> - None - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] option syntax" name - in - match name with - | "tool_name" -> - tool_name_ref := get_string payload - | "include_dirs" -> - Clflags.include_dirs := get_list get_string payload - | "load_path" -> - Migrate_parsetree_compiler_functions.load_path_init (get_list get_string payload) - | "open_modules" -> - Clflags.open_modules := get_list get_string payload - | "for_package" -> - Clflags.for_package := get_option get_string payload - | "debug" -> - Clflags.debug := get_bool payload - | "use_threads" -> - Clflags.use_threads := get_bool payload - | "use_vmthreads" -> - if get_bool payload then - raise_errorf "Internal error: vmthreads not supported after 4.09.0" - | "recursive_types" -> - Clflags.recursive_types := get_bool payload - | "principal" -> - Clflags.principal := get_bool payload - | "transparent_modules" -> - Clflags.transparent_modules := get_bool payload - | "unboxed_types" -> - Migrate_parsetree_compiler_functions.set_unboxed_types (get_bool payload) - | "cookies" -> - let l = get_list (get_pair get_string (fun x -> x)) payload in - cookies := - List.fold_left - (fun s (k, v) -> String.Map.add k v s) String.Map.empty - l - | _ -> - () - in - List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields - - let update_cookies fields = - let fields = - List.filter - (function ({txt=Lident "cookies"}, _) -> false | _ -> true) - fields - in - fields @ [get_cookies ()] - end - - let ppx_context = PpxContext.make - - let extension_of_exn exn = extension_of_error (Locations.location_error_of_exn exn) - - let apply_lazy ~source ~target mapper = - let implem ast = - let fields, ast = - match ast with - | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.structure mapper ast - with exn -> - [{pstr_desc = Pstr_extension (extension_of_exn exn, []); - pstr_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Str.attribute (PpxContext.mk fields) :: ast - in - let iface ast = - let fields, ast = - match ast with - | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x; - attr_loc = _})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.signature mapper ast - with exn -> - [{psig_desc = Psig_extension (extension_of_exn exn, []); - psig_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Sig.attribute (PpxContext.mk fields) :: ast - in - - let ic = open_in_bin source in - let magic = - really_input_string ic (String.length Config.ast_impl_magic_number) - in - - let rewrite transform = - Location.input_name := input_value ic; - let ast = input_value ic in - close_in ic; - let ast = transform ast in - let oc = open_out_bin target in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc - and fail () = - close_in ic; - failwith "Ast_mapper: OCaml version mismatch or malformed input"; - in - - if magic = Config.ast_impl_magic_number then - rewrite (implem : structure -> structure) - else if magic = Config.ast_intf_magic_number then - rewrite (iface : signature -> signature) - else fail () - - let drop_ppx_context_str ~restore = function - | {pstr_desc = Pstr_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - - let drop_ppx_context_sig ~restore = function - | {psig_desc = Psig_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - - let add_ppx_context_str ~tool_name ast = - Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast - - let add_ppx_context_sig ~tool_name ast = - Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast - - - let apply ~source ~target mapper = - apply_lazy ~source ~target (fun () -> mapper) - - let run_main mapper = - try - let a = Sys.argv in - let n = Array.length a in - if n > 2 then - let mapper () = - try mapper (Array.to_list (Array.sub a 1 (n - 3))) - with exn -> - (* PR#6463 *) - let f _ _ = raise exn in - {default_mapper with structure = f; signature = f} - in - apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper - else begin - Printf.eprintf "Usage: %s [extra_args] \n%!" - Sys.executable_name; - exit 2 - end - with exn -> - prerr_endline (Printexc.to_string exn); - exit 2 - - let register_function = ref (fun _name f -> run_main f) - let register name f = !register_function name f - end - module Type_immediacy = struct type t (*IF_CURRENT = Type_immediacy.t *) = | Unknown @@ -4079,120 +208,3 @@ module Outcometree = struct | Ophr_signature of (out_sig_item * out_value option) list | Ophr_exception of (exn * out_value) end - -module Config = struct - let ast_impl_magic_number = "Caml1999M029" - let ast_intf_magic_number = "Caml1999N029" -end - -let map_signature mapper = mapper.Ast_mapper.signature mapper -let map_structure mapper = mapper.Ast_mapper.structure mapper - -let shallow_identity = - let id _ x = x in - { - Ast_mapper. - structure = id; - structure_item = id; - module_expr = id; - signature = id; - signature_item = id; - module_type = id; - with_constraint = id; - class_declaration = id; - class_expr = id; - class_field = id; - class_structure = id; - class_type = id; - class_type_field = id; - class_signature = id; - class_type_declaration = id; - class_description = id; - type_declaration = id; - type_kind = id; - typ = id; - type_extension = id; - extension_constructor = id; - value_description = id; - pat = id; - expr = id; - module_declaration = id; - module_type_declaration = id; - module_binding = id; - open_description = id; - include_description = id; - include_declaration = id; - value_binding = id; - constructor_declaration = id; - label_declaration = id; - cases = id; - case = id; - location = id; - extension = id; - attribute = id; - attributes = id; - payload = id; - binding_op = id; - module_substitution = id; - open_declaration = id; - type_exception = id; - constant = id; - } - -let failing_mapper = - let fail _ _ = - invalid_arg "failing_mapper: this mapper function should never get called" - in - { - Ast_mapper. - structure = fail; - structure_item = fail; - module_expr = fail; - signature = fail; - signature_item = fail; - module_type = fail; - with_constraint = fail; - class_declaration = fail; - class_expr = fail; - class_field = fail; - class_structure = fail; - class_type = fail; - class_type_field = fail; - class_signature = fail; - class_type_declaration = fail; - class_description = fail; - type_declaration = fail; - type_kind = fail; - typ = fail; - type_extension = fail; - extension_constructor = fail; - value_description = fail; - pat = fail; - expr = fail; - module_declaration = fail; - module_type_declaration = fail; - module_binding = fail; - open_description = fail; - include_description = fail; - include_declaration = fail; - value_binding = fail; - constructor_declaration = fail; - label_declaration = fail; - cases = fail; - case = fail; - location = fail; - extension = fail; - attribute = fail; - attributes = fail; - payload = fail; - binding_op = fail; - module_substitution = fail; - open_declaration = fail; - type_exception = fail; - constant = fail; - } - -let make_top_mapper ~signature ~structure = - {failing_mapper with Ast_mapper. - signature = (fun _ x -> signature x); - structure = (fun _ x -> structure x) } diff --git a/src/vendored-omp/src/ast_413.ml b/src/vendored-omp/src/ast_413.ml index 212efd026..ed2026ff9 100644 --- a/src/vendored-omp/src/ast_413.ml +++ b/src/vendored-omp/src/ast_413.ml @@ -17,3952 +17,51 @@ (* *) (**************************************************************************) -open Ast_409_helper - -module Asttypes = struct - type constant (*IF_CURRENT = Asttypes.constant *) = - Const_int of int - | Const_char of char - | Const_string of string * Location.t * string option - | Const_float of string - | Const_int32 of int32 - | Const_int64 of int64 - | Const_nativeint of nativeint - - type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive - - type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto - - (* Order matters, used in polymorphic comparison *) - type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - - type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - - type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - - type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh - - type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open - - type label = string - - type arg_label (*IF_CURRENT = Asttypes.arg_label *) = - Nolabel - | Labelled of string (* label:T -> ... *) - | Optional of string (* ?label:T -> ... *) - - type 'a loc = 'a Location.loc = { - txt : 'a; - loc : Location.t; - } - - type variance (*IF_CURRENT = Asttypes.variance *) = - | Covariant - | Contravariant - | NoVariance - - type injectivity (*IF_CURRENT = Asttypes.injectivity *) = - | Injective - | NoInjectivity -end - -module Parsetree = struct - open Asttypes - - type constant (*IF_CURRENT = Parsetree.constant *) = - Pconst_integer of string * char option - (* 3 3l 3L 3n - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker - *) - | Pconst_char of char - (* 'c' *) - | Pconst_string of string * Location.t * string option - (* "constant" - {delim|other constant|delim} - - The location span the content of the string, without the delimiters. - *) - | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - - type location_stack = Location.t list - - (** {1 Extension points} *) - - type attribute (*IF_CURRENT = Parsetree.attribute *) = { - attr_name : string loc; - attr_payload : payload; - attr_loc : Location.t; - } - (* [@id ARG] - [@@id ARG] - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - - and extension = string loc * payload - (* [%id ARG] - [%%id ARG] - - Sub-language placeholder -- rejected by the typechecker. - *) - - and attributes = attribute list - - and payload (*IF_CURRENT = Parsetree.payload *) = - | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - - (** {1 Core language} *) - - (* Type expressions *) - - and core_type (*IF_CURRENT = Parsetree.core_type *) = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_loc_stack: location_stack; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional - *) - | Ptyp_tuple of core_type list - (* T1 * ... * Tn - - Invariant: n >= 2 - *) - | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of object_field list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). - - - As the core_type of a Pctf_method node. - - - As the core_type of a Pexp_poly node. - - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) - - and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) - - and row_field (*IF_CURRENT = Parsetree.row_field *) = { - prf_desc : row_field_desc; - prf_loc : Location.t; - prf_attributes : attributes; - } - - and row_field_desc (*IF_CURRENT = Parsetree.row_field_desc *) = - | Rtag of label loc * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 'bool' field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - *) - | Rinherit of core_type - (* [ T ] *) - - and object_field (*IF_CURRENT = Parsetree.object_field *) = { - pof_desc : object_field_desc; - pof_loc : Location.t; - pof_attributes : attributes; - } - - and object_field_desc (*IF_CURRENT = Parsetree.object_field_desc *) = - | Otag of label loc * core_type - | Oinherit of core_type - - (* Patterns *) - - and pattern (*IF_CURRENT = Parsetree.pattern *) = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_loc_stack: location_stack; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Ppat_interval of constant * constant - (* 'a'..'z' - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (* (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Ppat_construct of Longident.t loc * (string loc list * pattern) option - (* C None - C P Some ([], P) - C (P1, ..., Pn) Some ([], Ppat_tuple [P1; ...; Pn]) - C (type a b) P Some ([a; b], P) - *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) - | Ppat_unpack of string option loc - (* (module P) Some "P" - (module _) None - - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of Longident.t loc * pattern - (* M.(P) *) - - (* Value expressions *) - - and expression (*IF_CURRENT = Parsetree.expression *) = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_loc_stack: location_stack; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = - | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) - | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_tuple of expression list - (* (E1, ..., En) - - Invariant: n >= 2 - *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) - | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) - | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * label loc - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of label loc * expression - (* x <- 2 *) - | Pexp_override of (label loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) - | Pexp_letmodule of string option loc * module_expr * expression - (* let module M = ME in E *) - | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) - | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) - | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string loc * expression - (* fun (type t) -> E *) - | Pexp_pack of module_expr - (* (module ME) - - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of open_declaration * expression - (* M.(E) - let open M in E - let! open M in E *) - | Pexp_letop of letop - (* let* P = E in E - let* P = E and* P = E in E *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable - (* . *) - - and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - - and letop (*IF_CURRENT = Parsetree.letop *) = - { - let_ : binding_op; - ands : binding_op list; - body : expression; - } - - and binding_op (*IF_CURRENT = Parsetree.binding_op *) = - { - pbop_op : string loc; - pbop_pat : pattern; - pbop_exp : expression; - pbop_loc : Location.t; - } - - (* Value descriptions *) - - and value_description (*IF_CURRENT = Parsetree.value_description *) = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } - -(* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) -*) - - (* Type declarations *) - - and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = - { - ptype_name: string loc; - ptype_params: (core_type * (variance * injectivity)) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } - -(* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) -*) - - and type_kind (*IF_CURRENT = Parsetree.type_kind *) = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) - | Ptype_open - - and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l : T [@id1] [@id2] *) - } - - (* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. - *) - - and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = - { - pcd_name: string loc; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - -(* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) -*) - - and type_extension (*IF_CURRENT = Parsetree.type_extension *) = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * (variance * injectivity)) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_loc: Location.t; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } -(* - type t += ... -*) - - and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - (* exception E *) - and type_exception (*IF_CURRENT = Parsetree.type_exception *) = - { - ptyexn_constructor: extension_constructor; - ptyexn_loc: Location.t; - ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = - Pext_decl of constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([T1; ...; Tn], None) - | C: T0 ([], Some T0) - | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) - *) - | Pext_rebind of Longident.t loc - (* - | C = D - *) - - (** {1 Class language} *) - - (* Type expressions for the class language *) - - and class_type (*IF_CURRENT = Parsetree.class_type *) = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = - | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) - | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - | Pcty_open of open_description * class_type - (* let open M in CT *) - - and class_signature (*IF_CURRENT = Parsetree.class_signature *) = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } - (* object('selfpat) ... end - object ... end (self = Ptyp_any) - *) - - and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = - | Pctf_inherit of class_type - (* inherit CT *) - | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) - - and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = - { - pci_virt: virtual_flag; - pci_params: (core_type * (variance * injectivity)) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... - - Also used for "class type" declaration. - *) - - and class_description = class_type class_infos - - and class_type_declaration = class_type class_infos - - (* Value expressions for the class language *) - - and class_expr (*IF_CURRENT = Parsetree.class_expr *) = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = - | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - | Pcl_open of open_description * class_expr - (* let open M in CE *) - - - and class_structure (*IF_CURRENT = Parsetree.class_structure *) = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } - (* object(selfpat) ... end - object ... end (self = Ppat_any) - *) - - and class_field (*IF_CURRENT = Parsetree.class_field *) = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_field_desc (*IF_CURRENT = Parsetree.class_field_desc *) = - | Pcf_inherit of override_flag * class_expr * string loc option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) - | Pcf_val of (label loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) - | Pcf_method of (label loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) - - and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - - and class_declaration = class_expr class_infos - - (** {1 Module language} *) - - (* Type expressions for the module language *) - - and module_type (*IF_CURRENT = Parsetree.module_type *) = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) - | Pmty_functor of functor_parameter * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) - - and functor_parameter (*IF_CURRENT = Parsetree.functor_parameter *) = - | Unit - (* () *) - | Named of string option loc * module_type - (* (X : MT) Some X, MT - (_ : MT) None, MT *) - - and signature = signature_item list - - and signature_item (*IF_CURRENT = Parsetree.signature_item *) = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - - and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = - | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) - | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typesubst of type_declaration list - (* type t1 := ... and ... and tn := ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of type_exception - (* exception C of T *) - | Psig_module of module_declaration - (* module X = M - module X : MT *) - | Psig_modsubst of module_substitution - (* module X := M *) - | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) - | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_modtypesubst of module_type_declaration - (* module type S := ... *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) - | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) - - and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = - { - pmd_name: string option loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } - (* S : MT *) - - and module_substitution (*IF_CURRENT = Parsetree.module_substitution *) = - { - pms_name: string loc; - pms_manifest: Longident.t loc; - pms_attributes: attributes; (* ... [@@id1] [@@id2] *) - pms_loc: Location.t; - } - - and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } - (* S = MT - S (abstract module type declaration, pmtd_type = None) - *) - - and 'a open_infos (*IF_CURRENT = 'a Parsetree.open_infos *) = - { - popen_expr: 'a; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } - (* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) - - and open_description = Longident.t loc open_infos - (* open M.N - open M(N).O *) - - and open_declaration = module_expr open_infos - (* open M.N - open M(N).O - open struct ... end *) - - and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - - and include_description = module_type include_infos - (* include MT *) - - and include_declaration = module_expr include_infos - (* include ME *) - - and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = - | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) - | Pwith_modtype of Longident.t loc * module_type - (* with module type X.Y = Z *) - | Pwith_modtypesubst of Longident.t loc * module_type - (* with module type X.Y := sig end *) - | Pwith_typesubst of Longident.t loc * type_declaration - (* with type X.t := ..., same format as [Pwith_type] *) - | Pwith_modsubst of Longident.t loc * Longident.t loc - (* with module X.Y := Z *) - - (* Value expressions for the module language *) - - and module_expr (*IF_CURRENT = Parsetree.module_expr *) = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) - | Pmod_functor of functor_parameter * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) - - and structure = structure_item list - - and structure_item (*IF_CURRENT = Parsetree.structure_item *) = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - - and structure_item_desc (*IF_CURRENT = Parsetree.structure_item_desc *) = - | Pstr_eval of expression * attributes - (* E *) - | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) - | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) - | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) - | Pstr_exception of type_exception - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) - | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_declaration - (* open X *) - | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) - | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) - - and value_binding (*IF_CURRENT = Parsetree.value_binding *) = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - - and module_binding (*IF_CURRENT = Parsetree.module_binding *) = - { - pmb_name: string option loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } - (* X = ME *) - - (** {1 Toplevel} *) - - (* Toplevel phrases *) - - type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = - | Ptop_def of structure - | Ptop_dir of toplevel_directive - (* #use, #load ... *) - - and toplevel_directive (*IF_CURRENT = Parsetree.toplevel_directive *) = - { - pdir_name : string loc; - pdir_arg : directive_argument option; - pdir_loc : Location.t; - } - - and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = - { - pdira_desc : directive_argument_desc; - pdira_loc : Location.t; - } - - and directive_argument_desc (*IF_CURRENT = Parsetree.directive_argument_desc *) = - | Pdir_string of string - | Pdir_int of string * char option - | Pdir_ident of Longident.t - | Pdir_bool of bool -end - -module Docstrings : sig - -(** Documentation comments - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -(** (Re)Initialise all docstring state *) -val init : unit -> unit - -(** Emit warnings for unattached and ambiguous docstrings *) -val warn_bad_docstrings : unit -> unit - -(** {2 Docstrings} *) - -(** Documentation comments *) -type docstring - -(** Create a docstring *) -val docstring : string -> Location.t -> docstring - -(** Register a docstring *) -val register : docstring -> unit - -(** Get the text of a docstring *) -val docstring_body : docstring -> string - -(** Get the location of a docstring *) -val docstring_loc : docstring -> Location.t - -(** {2 Set functions} - - These functions are used by the lexer to associate docstrings to - the locations of tokens. *) - -(** Docstrings immediately preceding a token *) -val set_pre_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following a token *) -val set_post_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings not immediately adjacent to a token *) -val set_floating_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following the token which precedes this one *) -val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately preceding the token which follows this one *) -val set_post_extra_docstrings : Lexing.position -> docstring list -> unit - -(** {2 Items} - - The {!docs} type represents documentation attached to an item. *) - -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - -val empty_docs : docs - -val docs_attr : docstring -> Parsetree.attribute - -(** Convert item documentation to attributes and add them to an - attribute list *) -val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) -val symbol_docs : unit -> docs -val symbol_docs_lazy : unit -> docs Lazy.t - -(** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) -val rhs_docs : int -> int -> docs -val rhs_docs_lazy : int -> int -> docs Lazy.t - -(** Mark the item documentation for the current symbol (for ambiguity - warnings). *) -val mark_symbol_docs : unit -> unit - -(** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) -val mark_rhs_docs : int -> int -> unit - -(** {2 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - -type info = docstring option - -val empty_info : info - -val info_attr : docstring -> Parsetree.attribute - -(** Convert field info to attributes and add them to an - attribute list *) -val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the field info for the current symbol. *) -val symbol_info : unit -> info - -(** Fetch the field info following the symbol at a given position. *) -val rhs_info : int -> info - -(** {2 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - -type text = docstring list - -val empty_text : text -val empty_text_lazy : text Lazy.t - -val text_attr : docstring -> Parsetree.attribute - -(** Convert text to attributes and add them to an attribute list *) -val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the text preceding the current symbol. *) -val symbol_text : unit -> text -val symbol_text_lazy : unit -> text Lazy.t - -(** Fetch the text preceding the symbol at the given position. *) -val rhs_text : int -> text -val rhs_text_lazy : int -> text Lazy.t - -(** {2 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - -(** Fetch additional text preceding the current symbol *) -val symbol_pre_extra_text : unit -> text - -(** Fetch additional text following the current symbol *) -val symbol_post_extra_text : unit -> text - -(** Fetch additional text preceding the symbol at the given position *) -val rhs_pre_extra_text : int -> text - -(** Fetch additional text following the symbol at the given position *) -val rhs_post_extra_text : int -> text - -(** Fetch text following the symbol at the given position *) -val rhs_post_text : int -> text - -module WithMenhir: sig -(** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) -val symbol_docs : Lexing.position * Lexing.position -> docs -val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t - -(** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) -val rhs_docs : Lexing.position -> Lexing.position -> docs -val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t - -(** Mark the item documentation for the current symbol (for ambiguity - warnings). *) -val mark_symbol_docs : Lexing.position * Lexing.position -> unit - -(** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) -val mark_rhs_docs : Lexing.position -> Lexing.position -> unit - -(** Fetch the field info for the current symbol. *) -val symbol_info : Lexing.position -> info - -(** Fetch the field info following the symbol at a given position. *) -val rhs_info : Lexing.position -> info - -(** Fetch the text preceding the current symbol. *) -val symbol_text : Lexing.position -> text -val symbol_text_lazy : Lexing.position -> text Lazy.t - -(** Fetch the text preceding the symbol at the given position. *) -val rhs_text : Lexing.position -> text -val rhs_text_lazy : Lexing.position -> text Lazy.t - -(** {3 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - -(** Fetch additional text preceding the current symbol *) -val symbol_pre_extra_text : Lexing.position -> text - -(** Fetch additional text following the current symbol *) -val symbol_post_extra_text : Lexing.position -> text - -(** Fetch additional text preceding the symbol at the given position *) -val rhs_pre_extra_text : Lexing.position -> text - -(** Fetch additional text following the symbol at the given position *) -val rhs_post_extra_text : Lexing.position -> text - -(** Fetch text following the symbol at the given position *) -val rhs_post_text : Lexing.position -> text - -end -end = struct - -open Location - -(* Docstrings *) - -(* A docstring is "attached" if it has been inserted in the AST. This - is used for generating unexpected docstring warnings. *) -type ds_attached = - | Unattached (* Not yet attached anything.*) - | Info (* Attached to a field or constructor. *) - | Docs (* Attached to an item or as floating text. *) - -(* A docstring is "associated" with an item if there are no blank lines between - them. This is used for generating docstring ambiguity warnings. *) -type ds_associated = - | Zero (* Not associated with an item *) - | One (* Associated with one item *) - | Many (* Associated with multiple items (ambiguity) *) - -type docstring = - { ds_body: string; - ds_loc: Location.t; - mutable ds_attached: ds_attached; - mutable ds_associated: ds_associated; } - -(* List of docstrings *) - -let docstrings : docstring list ref = ref [] - -(* Warn for unused and ambiguous docstrings *) - -let warn_bad_docstrings () = - if Warnings.is_active (Migrate_parsetree_compiler_functions.bad_docstring true) then begin - List.iter - (fun ds -> - match ds.ds_attached with - | Info -> () - | Unattached -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring true) - | Docs -> - match ds.ds_associated with - | Zero | One -> () - | Many -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring false)) - (List.rev !docstrings) - end - -(* Docstring constructors and destructors *) - -let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; - ds_attached = Unattached; - ds_associated = Zero; } - in - ds - -let register ds = - docstrings := ds :: !docstrings - -let docstring_body ds = ds.ds_body - -let docstring_loc ds = ds.ds_loc - -(* Docstrings attached to items *) - -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - -let empty_docs = { docs_pre = None; docs_post = None } - -let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - -let docs_attr ds = - let open Parsetree in - let body = ds.ds_body in - let loc = ds.ds_loc in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } - in - { attr_name = doc_loc; - attr_payload = PStr [item]; - attr_loc = loc } - -let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - -(* Docstrings attached to constructors or fields *) - -type info = docstring option - -let empty_info = None - -let info_attr = docs_attr - -let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - -(* Docstrings not attached to a specific item *) - -type text = docstring list - -let empty_text = [] -let empty_text_lazy = lazy [] - -let text_loc = {txt = "ocaml.text"; loc = Location.none} - -let text_attr ds = - let open Parsetree in - let body = ds.ds_body in - let loc = ds.ds_loc in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } - in - { attr_name = text_loc; - attr_payload = PStr [item]; - attr_loc = loc } - -let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - -(* Find the first non-info docstring in a list, attach it and return it *) -let get_docstring ~info dsl = - let rec loop = function - | [] -> None - | {ds_attached = Info; _} :: rest -> loop rest - | ds :: _ -> - ds.ds_attached <- if info then Info else Docs; - Some ds - in - loop dsl - -(* Find all the non-info docstrings in a list, attach them and return them *) -let get_docstrings dsl = - let rec loop acc = function - | [] -> List.rev acc - | {ds_attached = Info; _} :: rest -> loop acc rest - | ds :: rest -> - ds.ds_attached <- Docs; - loop (ds :: acc) rest - in - loop [] dsl - -(* "Associate" all the docstrings in a list *) -let associate_docstrings dsl = - List.iter - (fun ds -> - match ds.ds_associated with - | Zero -> ds.ds_associated <- One - | (One | Many) -> ds.ds_associated <- Many) - dsl - -(* Map from positions to pre docstrings *) - -let pre_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_pre_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_table pos dsl - -let get_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - -let mark_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl - with Not_found -> () - -(* Map from positions to post docstrings *) - -let post_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_post_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_table pos dsl - -let get_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - -let mark_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl - with Not_found -> () - -let get_info pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstring ~info:true dsl - with Not_found -> None - -(* Map from positions to floating docstrings *) - -let floating_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_floating_docstrings pos dsl = - if dsl <> [] then Hashtbl.add floating_table pos dsl - -let get_text pos = - try - let dsl = Hashtbl.find floating_table pos in - get_docstrings dsl - with Not_found -> [] - -let get_post_text pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstrings dsl - with Not_found -> [] - -(* Maps from positions to extra docstrings *) - -let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_pre_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_extra_table pos dsl - -let get_pre_extra_text pos = - try - let dsl = Hashtbl.find pre_extra_table pos in - get_docstrings dsl - with Not_found -> [] - -let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_post_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_extra_table pos dsl - -let get_post_extra_text pos = - try - let dsl = Hashtbl.find post_extra_table pos in - get_docstrings dsl - with Not_found -> [] - -(* Docstrings from parser actions *) -module WithParsing = struct -let symbol_docs () = - { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); - docs_post = get_post_docs (Parsing.symbol_end_pos ()); } - -let symbol_docs_lazy () = - let p1 = Parsing.symbol_start_pos () in - let p2 = Parsing.symbol_end_pos () in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); - docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } - -let rhs_docs_lazy pos1 pos2 = - let p1 = Parsing.rhs_start_pos pos1 in - let p2 = Parsing.rhs_end_pos pos2 in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let mark_symbol_docs () = - mark_pre_docs (Parsing.symbol_start_pos ()); - mark_post_docs (Parsing.symbol_end_pos ()) - -let mark_rhs_docs pos1 pos2 = - mark_pre_docs (Parsing.rhs_start_pos pos1); - mark_post_docs (Parsing.rhs_end_pos pos2) - -let symbol_info () = - get_info (Parsing.symbol_end_pos ()) - -let rhs_info pos = - get_info (Parsing.rhs_end_pos pos) - -let symbol_text () = - get_text (Parsing.symbol_start_pos ()) - -let symbol_text_lazy () = - let pos = Parsing.symbol_start_pos () in - lazy (get_text pos) - -let rhs_text pos = - get_text (Parsing.rhs_start_pos pos) - -let rhs_post_text pos = - get_post_text (Parsing.rhs_end_pos pos) - -let rhs_text_lazy pos = - let pos = Parsing.rhs_start_pos pos in - lazy (get_text pos) - -let symbol_pre_extra_text () = - get_pre_extra_text (Parsing.symbol_start_pos ()) - -let symbol_post_extra_text () = - get_post_extra_text (Parsing.symbol_end_pos ()) - -let rhs_pre_extra_text pos = - get_pre_extra_text (Parsing.rhs_start_pos pos) - -let rhs_post_extra_text pos = - get_post_extra_text (Parsing.rhs_end_pos pos) -end - -include WithParsing - -module WithMenhir = struct -let symbol_docs (startpos, endpos) = - { docs_pre = get_pre_docs startpos; - docs_post = get_post_docs endpos; } - -let symbol_docs_lazy (p1, p2) = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs pos1; - docs_post = get_post_docs pos2; } - -let rhs_docs_lazy p1 p2 = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let mark_symbol_docs (startpos, endpos) = - mark_pre_docs startpos; - mark_post_docs endpos; - () - -let mark_rhs_docs pos1 pos2 = - mark_pre_docs pos1; - mark_post_docs pos2; - () - -let symbol_info endpos = - get_info endpos - -let rhs_info endpos = - get_info endpos - -let symbol_text startpos = - get_text startpos - -let symbol_text_lazy startpos = - lazy (get_text startpos) - -let rhs_text pos = - get_text pos - -let rhs_post_text pos = - get_post_text pos - -let rhs_text_lazy pos = - lazy (get_text pos) - -let symbol_pre_extra_text startpos = - get_pre_extra_text startpos - -let symbol_post_extra_text endpos = - get_post_extra_text endpos - -let rhs_pre_extra_text pos = - get_pre_extra_text pos - -let rhs_post_extra_text pos = - get_post_extra_text pos -end - -(* (Re)Initialise all comment state *) - -let init () = - docstrings := []; - Hashtbl.reset pre_table; - Hashtbl.reset post_table; - Hashtbl.reset floating_table; - Hashtbl.reset pre_extra_table; - Hashtbl.reset post_extra_table -end - -module Ast_helper : sig - -(** Helpers to produce Parsetree fragments - - {b Warning} This module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Asttypes -open Docstrings -open Parsetree - -type 'a with_loc = 'a Location.loc -type loc = Location.t - -type lid = Longident.t with_loc -type str = string with_loc -type str_opt = string option with_loc -type attrs = attribute list - -(** {1 Default locations} *) - -val default_loc: loc ref - (** Default value for all optional location arguments. *) - -val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - -(** {1 Constants} *) - -module Const : sig - val char : char -> constant - val string : - ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant -end - -(** {1 Attributes} *) -module Attr : sig - val mk: ?loc:loc -> str -> payload -> attribute -end - -(** {1 Core language} *) - -(** Type expressions *) -module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - -(** Patterns *) -module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> - lid -> (str list * pattern) option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - -(** Expressions *) -module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr - -> expression -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression - -> expression - val letop: ?loc:loc -> ?attrs:attrs -> binding_op - -> binding_op list -> expression -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - val binding_op: str -> pattern -> expression -> loc -> binding_op - end - -(** Value declarations *) -module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - -(** Type declarations *) -module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * (variance * injectivity)) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - -(** Type extensions *) -module Te: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * (variance * injectivity)) list -> - ?priv:private_flag -> lid -> extension_constructor list -> type_extension - - val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - extension_constructor -> type_exception - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - -(** {1 Module language} *) - -(** Module type expressions *) -module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - -(** Module expressions *) -module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - -(** Signature items *) -module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_subst: ?loc:loc -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> type_exception -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val mod_subst: ?loc:loc -> module_substitution -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val modtype_subst: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - -(** Structure items *) -module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> type_exception -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_declaration -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - -(** Module declarations *) -module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_type -> module_declaration - end - -(** Module substitutions *) -module Ms: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> lid -> module_substitution - end - -(** Module type declarations *) -module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - -(** Module bindings *) -module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_expr -> module_binding - end - -(** Opens *) -module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> 'a -> 'a open_infos - end - -(** Includes *) -module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - -(** Value bindings *) -module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - -(** {1 Class language} *) - -(** Class type expressions *) -module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type - -> class_type - end - -(** Class type fields *) -module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - -(** Class expressions *) -module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr - -> class_expr - end - -(** Class fields *) -module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - -(** Classes *) -module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> - ?params:(core_type * (variance * injectivity)) list -> - str -> 'a -> 'a class_infos - end - -(** Class signatures *) -module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - -(** Class structures *) -module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - -(** Row fields *) -module Rf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> bool -> core_type list -> row_field - val inherit_: ?loc:loc -> core_type -> row_field - end - -(** Object fields *) -module Of: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - object_field_desc -> object_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> core_type -> object_field - val inherit_: ?loc:loc -> core_type -> object_field - end -end = struct -(** Helpers to produce Parsetree fragments *) - -open Asttypes -open Parsetree -open Docstrings - -type 'a with_loc = 'a Location.loc -type loc = Location.t - -type lid = Longident.t with_loc -type str = string with_loc -type str_opt = string option with_loc -type attrs = attribute list - -let default_loc = ref Location.none - -let with_default_loc l f = - Misc.protect_refs [Misc.R (default_loc, l)] f - -module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (string_of_int i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter ?(loc= !default_loc) s = - Pconst_string (s, loc, quotation_delimiter) -end - -module Attr = struct - let mk ?(loc= !default_loc) name payload = - { attr_name = name; - attr_payload = payload; - attr_loc = loc } -end - -module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; - ptyp_loc = loc; - ptyp_loc_stack = []; - ptyp_attributes = attrs} - - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - - let varify_constructors var_names t = - let check_variable vl loc v = - if List.mem v vl then - raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in - let var_names = List.map (fun v -> v.txt) var_names in - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> - check_variable var_names t.ptyp_loc x; - Ptyp_var x - | Ptyp_arrow (label,core_type,core_type') -> - Ptyp_arrow(label, loop core_type, loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr( { txt = Longident.Lident s }, []) - when List.mem s var_names -> - Ptyp_var s - | Ptyp_constr(longident, lst) -> - Ptyp_constr(longident, List.map loop lst) - | Ptyp_object (lst, o) -> - Ptyp_object (List.map loop_object_field lst, o) - | Ptyp_class (longident, lst) -> - Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) - in - {t with ptyp_desc = desc} - and loop_row_field field = - let prf_desc = match field.prf_desc with - | Rtag(label,flag,lst) -> - Rtag(label,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - in - { field with prf_desc; } - and loop_object_field field = - let pof_desc = match field.pof_desc with - | Otag(label, t) -> - Otag(label, loop t) - | Oinherit t -> - Oinherit (loop t) - in - { field with pof_desc; } - in - loop t - -end - -module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; - ppat_loc = loc; - ppat_loc_stack = []; - ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) -end - -module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b)) - let letop ?loc ?attrs let_ ands body = - mk ?loc ?attrs (Pexp_letop {let_; ands; body}) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - - let binding_op op pat exp loc = - { - pbop_op = op; - pbop_pat = pat; - pbop_exp = exp; - pbop_loc = loc; - } -end - -module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) -end - -module Mod = struct -let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg body = - mk ?loc ?attrs (Pmod_functor (arg, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) -end - -module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_subst ?loc a = mk ?loc (Psig_typesubst a) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let mod_subst ?loc a = mk ?loc (Psig_modsubst a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let modtype_subst ?loc a = mk ?loc (Psig_modtypesubst a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt -end - -module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt -end - -module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b)) -end - -module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b)) -end - -module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - -end - -module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - -end - -module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } -end - -module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } -end - -module Ms = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name syn = - { - pms_name = name; - pms_manifest = syn; - pms_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pms_loc = loc; - } -end - -module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } -end - -module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } -end - -module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) expr = - { - popen_expr = expr; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } -end - -module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - -end - -module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } -end - -module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } -end - -module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - -end - -(** Type extensions *) -module Te = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_loc = loc; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - constructor = - { - ptyexn_constructor = constructor; - ptyexn_loc = loc; - ptyexn_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - -end - -module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } -end - -module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } -end - -(** Row fields *) -module Rf = struct - let mk ?(loc = !default_loc) ?(attrs = []) desc = { - prf_desc = desc; - prf_loc = loc; - prf_attributes = attrs; - } - let tag ?loc ?attrs label const tys = - mk ?loc ?attrs (Rtag (label, const, tys)) - let inherit_?loc ty = - mk ?loc (Rinherit ty) -end - -(** Object fields *) -module Of = struct - let mk ?(loc = !default_loc) ?(attrs=[]) desc = { - pof_desc = desc; - pof_loc = loc; - pof_attributes = attrs; - } - let tag ?loc ?attrs label ty = - mk ?loc ?attrs (Otag (label, ty)) - let inherit_ ?loc ty = - mk ?loc (Oinherit ty) -end -end - -module Ast_mapper : sig -open Parsetree - -(** {1 A generic Parsetree mapper} *) - -type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; -} -(** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - -val default_mapper: mapper -(** A default mapper, which implements a "deep identity" mapping. *) - -(** {1 Apply mappers to compilation units} *) - -val tool_name: unit -> string -(** Can be used within a ppx preprocessor to know which tool is - calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], - ["ocaml"], ... Some global variables that reflect command-line - options are automatically synchronized between the calling tool - and the ppx preprocessor: {!Clflags.include_dirs}, - {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package}, - {!Clflags.debug}. *) - - -val apply: source:string -> target:string -> mapper -> unit -(** Apply a mapper (parametrized by the unit name) to a dumped - parsetree found in the [source] file and put the result in the - [target] file. The [structure] or [signature] field of the mapper - is applied to the implementation or interface. *) - -val run_main: (string list -> mapper) -> unit -(** Entry point to call to implement a standalone -ppx rewriter from a - mapper, parametrized by the command line arguments. The current - unit name can be obtained from {!Location.input_name}. This - function implements proper error reporting for uncaught - exceptions. *) - -(** {1 Registration API} *) - -val register_function: (string -> (string list -> mapper) -> unit) ref - -val register: string -> (string list -> mapper) -> unit -(** Apply the [register_function]. The default behavior is to run the - mapper immediately, taking arguments from the process command - line. This is to support a scenario where a mapper is linked as a - stand-alone executable. - It is possible to overwrite the [register_function] to define - "-ppx drivers", which combine several mappers in a single process. - Typically, a driver starts by defining [register_function] to a - custom implementation, then lets ppx rewriters (linked statically - or dynamically) register themselves, and then run all or some of - them. It is also possible to have -ppx drivers apply rewriters to - only specific parts of an AST. - The first argument to [register] is a symbolic name to be used by - the ppx driver. *) - - -(** {1 Convenience functions to write mappers} *) - -val map_opt: ('a -> 'b) -> 'a option -> 'b option - -val extension_of_error: Location.error -> extension -(** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) - -val attribute_of_warning: Location.t -> string -> attribute -(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) - -(** {1 Helper functions to call external mappers} *) - -val add_ppx_context_str: - tool_name:string -> Parsetree.structure -> Parsetree.structure -(** Extract information from the current environment and encode it - into an attribute which is prepended to the list of structure - items in order to pass the information to an external - processor. *) - -val add_ppx_context_sig: - tool_name:string -> Parsetree.signature -> Parsetree.signature -(** Same as [add_ppx_context_str], but for signatures. *) - -val drop_ppx_context_str: - restore:bool -> Parsetree.structure -> Parsetree.structure -(** Drop the ocaml.ppx.context attribute from a structure. If - [restore] is true, also restore the associated data in the current - process. *) - -val drop_ppx_context_sig: - restore:bool -> Parsetree.signature -> Parsetree.signature -(** Same as [drop_ppx_context_str], but for signatures. *) - -(** {1 Cookies} *) - -(** Cookies are used to pass information from a ppx processor to - a further invocation of itself, when called from the OCaml - toplevel (or other tools that support cookies). *) - -val set_cookie: string -> Parsetree.expression -> unit -val get_cookie: string -> Parsetree.expression option -end = struct - -(* A generic Parsetree mapping class *) - -(* -[@@@ocaml.warning "+9"] - (* Ensure that record patterns don't miss any field. *) -*) - -open Parsetree -open Ast_helper -open Location - -module String = Misc.Stdlib.String - - type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; -} - -let map_fst f (x, y) = (f x, y) -let map_snd f (x, y) = (x, f y) -let map_tuple f1 f2 (x, y) = (f1 x, f2 y) -let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) -let map_opt f = function None -> None | Some x -> Some (f x) - -let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - -module C = struct - (* Constants *) - - let map sub c = match c with - | Pconst_integer _ - | Pconst_char _ - | Pconst_float _ - -> c - | Pconst_string (s, loc, quotation_delimiter) -> - let loc = sub.location sub loc in - Const.string ~loc ?quotation_delimiter s -end - -module T = struct - (* Type expressions for the core language *) - - let row_field sub { - prf_desc; - prf_loc; - prf_attributes; - } = - let loc = sub.location sub prf_loc in - let attrs = sub.attributes sub prf_attributes in - let desc = match prf_desc with - | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - in - Rf.mk ~loc ~attrs desc - - let object_field sub { - pof_desc; - pof_loc; - pof_attributes; - } = - let loc = sub.location sub pof_loc in - let attrs = sub.attributes sub pof_attributes in - let desc = match pof_desc with - | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t) - | Oinherit t -> Oinherit (sub.typ sub t) - in - Of.mk ~loc ~attrs desc - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs - (List.map (map_loc sub) sl) (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - let loc = sub.location sub ptype_loc in - let attrs = sub.attributes sub ptype_attributes in - Type.mk ~loc ~attrs (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_loc; - ptyext_attributes} = - let loc = sub.location sub ptyext_loc in - let attrs = sub.attributes sub ptyext_attributes in - Te.mk ~loc ~attrs - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - - let map_type_exception sub - {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = - let loc = sub.location sub ptyexn_loc in - let attrs = sub.attributes sub ptyexn_attributes in - Te.mk_exception ~loc ~attrs - (sub.extension_constructor sub ptyexn_constructor) - - let map_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - let loc = sub.location sub pext_loc in - let attrs = sub.attributes sub pext_attributes in - Te.constructor ~loc ~attrs - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - -end - -module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (o, ct) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) -end - -let map_functor_param sub = function - | Unit -> Unit - | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt) - -module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (param, mt) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_type sub mt) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_modtype (lid, mty) -> - Pwith_modtype (map_loc sub lid, sub.module_type sub mty) - | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - | Pwith_modtypesubst (lid, mty) -> - Pwith_modtypesubst (map_loc sub lid, sub.module_type sub mty) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> - type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typesubst l -> - type_subst ~loc (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_modtypesubst x -> - modtype_subst ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) -end - - -module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (param, body) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - let attrs = sub.attributes sub attrs in - eval ~loc ~attrs (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_declaration sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) -end - -module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x) - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> - send ~loc ~attrs (sub.expr sub e) (map_loc sub s) - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (o, e) -> - open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e) - | Pexp_letop {let_; ands; body} -> - letop ~loc ~attrs (sub.binding_op sub let_) - (List.map (sub.binding_op sub) ands) (sub.expr sub body) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () - - let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = - let open Exp in - let op = map_loc sub pbop_op in - let pat = sub.pat sub pbop_pat in - let exp = sub.expr sub pbop_exp in - let loc = sub.location sub pbop_loc in - binding_op op pat exp loc - -end - -module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs (sub.constant sub c) - | Ppat_interval (c1, c2) -> - interval ~loc ~attrs (sub.constant sub c1) (sub.constant sub c2) - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) - (map_opt - (fun (vl, p) -> List.map (map_loc sub) vl, sub.pat sub p) - p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) -end - -module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (o, ce) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> - inherit_ ~loc ~attrs o (sub.class_expr sub ce) - (map_opt (map_loc sub) s) - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - let loc = sub.location sub pci_loc in - let attrs = sub.attributes sub pci_attributes in - Ci.mk ~loc ~attrs - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) -end - -(* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - -let default_mapper = - { - constant = C.map; - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - type_exception = T.map_type_exception; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - binding_op = E.map_binding_op; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_substitution = - (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> - Ms.mk - (map_loc this pms_name) - (map_loc this pms_manifest) - ~attrs:(this.attributes this pms_attributes) - ~loc:(this.location this pms_loc) - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_declaration = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (this.module_expr this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - open_description = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); +module Asttypes = struct + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * Location.t * string option + | Const_float of string + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint + type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); + type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto + (* Order matters, used in polymorphic comparison *) + type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); + type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); + type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); + type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh + type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open + type label = string - location = (fun _this l -> l); + type arg_label (*IF_CURRENT = Asttypes.arg_label *) = + Nolabel + | Labelled of string (* label:T -> ... *) + | Optional of string (* ?label:T -> ... *) - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this a -> - { - attr_name = map_loc this a.attr_name; - attr_payload = this.payload this a.attr_payload; - attr_loc = this.location this a.attr_loc - } - ); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); + type 'a loc = 'a Location.loc = { + txt : 'a; + loc : Location.t; } -let extension_of_error error = - Locations.extension_of_error - ~mk_pstr:(fun x -> PStr x) - ~mk_extension:(fun x -> Str.extension x) - ~mk_string_constant:(fun x -> Str.eval (Exp.constant (Pconst_string (x, Location.none (* XXX *), None)))) - error - -let attribute_of_warning loc s = - Attr.mk - {loc; txt = "ocaml.ppwarning" } - (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, loc, None)))])) - -let cookies = ref String.Map.empty - -let get_cookie k = - try Some (String.Map.find k !cookies) - with Not_found -> None - -let set_cookie k v = - cookies := String.Map.add k v !cookies - -let tool_name_ref = ref "_none_" - -let tool_name () = !tool_name_ref - - -module PpxContext = struct - open Longident - open Asttypes - open Ast_helper - - let lid name = { txt = Lident name; loc = Location.none } - - let make_string s = Exp.constant (Const.string s) - - let make_bool x = - if x - then Exp.construct (lid "true") None - else Exp.construct (lid "false") None - - let rec make_list f lst = - match lst with - | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) - | [] -> - Exp.construct (lid "[]") None - - let make_pair f1 f2 (x1, x2) = - Exp.tuple [f1 x1; f2 x2] - - let make_option f opt = - match opt with - | Some x -> Exp.construct (lid "Some") (Some (f x)) - | None -> Exp.construct (lid "None") None - - let get_cookies () = - lid "cookies", - make_list (make_pair make_string (fun x -> x)) - (String.Map.bindings !cookies) - - let mk fields = - { - attr_name = { txt = "ocaml.ppx.context"; loc = Location.none }; - attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)]; - attr_loc = Location.none - } - - let make ~tool_name () = - let fields = - [ - lid "tool_name", make_string tool_name; - lid "include_dirs", make_list make_string !Clflags.include_dirs; - lid "load_path", make_list make_string (Migrate_parsetree_compiler_functions.get_load_paths ()); - lid "open_modules", make_list make_string !Clflags.open_modules; - lid "for_package", make_option make_string !Clflags.for_package; - lid "debug", make_bool !Clflags.debug; - lid "use_threads", make_bool !Clflags.use_threads; - lid "use_vmthreads", make_bool false; - lid "recursive_types", make_bool !Clflags.recursive_types; - lid "principal", make_bool !Clflags.principal; - lid "transparent_modules", make_bool !Clflags.transparent_modules; - lid "unboxed_types", make_bool (Migrate_parsetree_compiler_functions.get_unboxed_types ()); - get_cookies () - ] - in - mk fields - - let get_fields = function - | PStr [{pstr_desc = Pstr_eval - ({ pexp_desc = Pexp_record (fields, None) }, [])}] -> - fields - | _ -> - raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" - - let restore fields = - let field name payload = - let rec get_string = function - | { pexp_desc = Pexp_constant (Pconst_string (str, _, None)) } -> str - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] string syntax" name - and get_bool pexp = - match pexp with - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, - None)} -> - true - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, - None)} -> - false - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] bool syntax" name - and get_list elem = function - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> - elem exp :: get_list elem rest - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> - [] - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] list syntax" name - and get_pair f1 f2 = function - | {pexp_desc = Pexp_tuple [e1; e2]} -> - (f1 e1, f2 e2) - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] pair syntax" name - and get_option elem = function - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> - Some (elem exp) - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> - None - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] option syntax" name - in - match name with - | "tool_name" -> - tool_name_ref := get_string payload - | "include_dirs" -> - Clflags.include_dirs := get_list get_string payload - | "load_path" -> - Migrate_parsetree_compiler_functions.load_path_init (get_list get_string payload) - | "open_modules" -> - Clflags.open_modules := get_list get_string payload - | "for_package" -> - Clflags.for_package := get_option get_string payload - | "debug" -> - Clflags.debug := get_bool payload - | "use_threads" -> - Clflags.use_threads := get_bool payload - | "use_vmthreads" -> - if get_bool payload then - raise_errorf "Internal error: vmthreads not supported after 4.09.0" - | "recursive_types" -> - Clflags.recursive_types := get_bool payload - | "principal" -> - Clflags.principal := get_bool payload - | "transparent_modules" -> - Clflags.transparent_modules := get_bool payload - | "unboxed_types" -> - Migrate_parsetree_compiler_functions.set_unboxed_types (get_bool payload) - | "cookies" -> - let l = get_list (get_pair get_string (fun x -> x)) payload in - cookies := - List.fold_left - (fun s (k, v) -> String.Map.add k v s) String.Map.empty - l - | _ -> - () - in - List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields - - let update_cookies fields = - let fields = - List.filter - (function ({txt=Lident "cookies"}, _) -> false | _ -> true) - fields - in - fields @ [get_cookies ()] -end - -let ppx_context = PpxContext.make - -let extension_of_exn exn = extension_of_error (Locations.location_error_of_exn exn) - -let apply_lazy ~source ~target mapper = - let implem ast = - let fields, ast = - match ast with - | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.structure mapper ast - with exn -> - [{pstr_desc = Pstr_extension (extension_of_exn exn, []); - pstr_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Str.attribute (PpxContext.mk fields) :: ast - in - let iface ast = - let fields, ast = - match ast with - | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x; - attr_loc = _})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.signature mapper ast - with exn -> - [{psig_desc = Psig_extension (extension_of_exn exn, []); - psig_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Sig.attribute (PpxContext.mk fields) :: ast - in - - let ic = open_in_bin source in - let magic = - really_input_string ic (String.length Config.ast_impl_magic_number) - in - - let rewrite transform = - Location.input_name := input_value ic; - let ast = input_value ic in - close_in ic; - let ast = transform ast in - let oc = open_out_bin target in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc - and fail () = - close_in ic; - failwith "Ast_mapper: OCaml version mismatch or malformed input"; - in - - if magic = Config.ast_impl_magic_number then - rewrite (implem : structure -> structure) - else if magic = Config.ast_intf_magic_number then - rewrite (iface : signature -> signature) - else fail () - -let drop_ppx_context_str ~restore = function - | {pstr_desc = Pstr_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - -let drop_ppx_context_sig ~restore = function - | {psig_desc = Psig_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - -let add_ppx_context_str ~tool_name ast = - Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast - -let add_ppx_context_sig ~tool_name ast = - Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast - - -let apply ~source ~target mapper = - apply_lazy ~source ~target (fun () -> mapper) - -let run_main mapper = - try - let a = Sys.argv in - let n = Array.length a in - if n > 2 then - let mapper () = - try mapper (Array.to_list (Array.sub a 1 (n - 3))) - with exn -> - (* PR#6463 *) - let f _ _ = raise exn in - {default_mapper with structure = f; signature = f} - in - apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper - else begin - Printf.eprintf "Usage: %s [extra_args] \n%!" - Sys.executable_name; - exit 2 - end - with exn -> - prerr_endline (Printexc.to_string exn); - exit 2 - -let register_function = ref (fun _name f -> run_main f) -let register name f = !register_function name f + type variance (*IF_CURRENT = Asttypes.variance *) = + | Covariant + | Contravariant + | NoVariance + type injectivity (*IF_CURRENT = Asttypes.injectivity *) = + | Injective + | NoInjectivity end module Type_immediacy = struct @@ -4110,121 +209,3 @@ and out_sig_item (*IF_CURRENT = Outcometree.out_sig_item *) = | Ophr_exception of (exn * out_value) end - -module Config = struct - let ast_impl_magic_number = "Caml1999M030" - let ast_intf_magic_number = "Caml1999N030" -end - - -let map_signature mapper = mapper.Ast_mapper.signature mapper -let map_structure mapper = mapper.Ast_mapper.structure mapper - -let shallow_identity = - let id _ x = x in - { - Ast_mapper. - structure = id; - structure_item = id; - module_expr = id; - signature = id; - signature_item = id; - module_type = id; - with_constraint = id; - class_declaration = id; - class_expr = id; - class_field = id; - class_structure = id; - class_type = id; - class_type_field = id; - class_signature = id; - class_type_declaration = id; - class_description = id; - type_declaration = id; - type_kind = id; - typ = id; - type_extension = id; - extension_constructor = id; - value_description = id; - pat = id; - expr = id; - module_declaration = id; - module_type_declaration = id; - module_binding = id; - open_description = id; - include_description = id; - include_declaration = id; - value_binding = id; - constructor_declaration = id; - label_declaration = id; - cases = id; - case = id; - location = id; - extension = id; - attribute = id; - attributes = id; - payload = id; - binding_op = id; - module_substitution = id; - open_declaration = id; - type_exception = id; - constant = id; - } - -let failing_mapper = - let fail _ _ = - invalid_arg "failing_mapper: this mapper function should never get called" - in - { - Ast_mapper. - structure = fail; - structure_item = fail; - module_expr = fail; - signature = fail; - signature_item = fail; - module_type = fail; - with_constraint = fail; - class_declaration = fail; - class_expr = fail; - class_field = fail; - class_structure = fail; - class_type = fail; - class_type_field = fail; - class_signature = fail; - class_type_declaration = fail; - class_description = fail; - type_declaration = fail; - type_kind = fail; - typ = fail; - type_extension = fail; - extension_constructor = fail; - value_description = fail; - pat = fail; - expr = fail; - module_declaration = fail; - module_type_declaration = fail; - module_binding = fail; - open_description = fail; - include_description = fail; - include_declaration = fail; - value_binding = fail; - constructor_declaration = fail; - label_declaration = fail; - cases = fail; - case = fail; - location = fail; - extension = fail; - attribute = fail; - attributes = fail; - payload = fail; - binding_op = fail; - module_substitution = fail; - open_declaration = fail; - type_exception = fail; - constant = fail; - } - -let make_top_mapper ~signature ~structure = - {failing_mapper with Ast_mapper. - signature = (fun _ x -> signature x); - structure = (fun _ x -> structure x) } diff --git a/src/vendored-omp/src/ast_414.ml b/src/vendored-omp/src/ast_414.ml index dd5095164..02aff7c32 100644 --- a/src/vendored-omp/src/ast_414.ml +++ b/src/vendored-omp/src/ast_414.ml @@ -17,4009 +17,60 @@ (* *) (**************************************************************************) -open Ast_409_helper - -module Asttypes = struct - type constant (*IF_CURRENT = Asttypes.constant *) = - Const_int of int - | Const_char of char - | Const_string of string * Location.t * string option - | Const_float of string - | Const_int32 of int32 - | Const_int64 of int64 - | Const_nativeint of nativeint - - type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive - - type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto - - (* Order matters, used in polymorphic comparison *) - type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - - type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - - type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - - type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh - - type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open - - type label = string - - type arg_label (*IF_CURRENT = Asttypes.arg_label *) = - Nolabel - | Labelled of string (* label:T -> ... *) - | Optional of string (* ?label:T -> ... *) - - type 'a loc = 'a Location.loc = { - txt : 'a; - loc : Location.t; - } - - type variance (*IF_CURRENT = Asttypes.variance *) = - | Covariant - | Contravariant - | NoVariance - - type injectivity (*IF_CURRENT = Asttypes.injectivity *) = - | Injective - | NoInjectivity -end - -module Parsetree = struct - open Asttypes - - type constant (*IF_CURRENT = Parsetree.constant *) = - Pconst_integer of string * char option - (* 3 3l 3L 3n - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker - *) - | Pconst_char of char - (* 'c' *) - | Pconst_string of string * Location.t * string option - (* "constant" - {delim|other constant|delim} - - The location span the content of the string, without the delimiters. - *) - | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - - type location_stack = Location.t list - - (** {1 Extension points} *) - - type attribute (*IF_CURRENT = Parsetree.attribute *) = { - attr_name : string loc; - attr_payload : payload; - attr_loc : Location.t; - } - (* [@id ARG] - [@@id ARG] - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - - and extension = string loc * payload - (* [%id ARG] - [%%id ARG] - - Sub-language placeholder -- rejected by the typechecker. - *) - - and attributes = attribute list - - and payload (*IF_CURRENT = Parsetree.payload *) = - | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - - (** {1 Core language} *) - - (* Type expressions *) - - and core_type (*IF_CURRENT = Parsetree.core_type *) = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_loc_stack: location_stack; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional - *) - | Ptyp_tuple of core_type list - (* T1 * ... * Tn - - Invariant: n >= 2 - *) - | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of object_field list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). - - - As the core_type of a Pctf_method node. - - - As the core_type of a Pexp_poly node. - - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - - - As the pval_type field of a value_description. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) - - and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) - - and row_field (*IF_CURRENT = Parsetree.row_field *) = { - prf_desc : row_field_desc; - prf_loc : Location.t; - prf_attributes : attributes; - } - - and row_field_desc (*IF_CURRENT = Parsetree.row_field_desc *) = - | Rtag of label loc * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 'bool' field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - *) - | Rinherit of core_type - (* [ | t ] *) - - and object_field (*IF_CURRENT = Parsetree.object_field *) = { - pof_desc : object_field_desc; - pof_loc : Location.t; - pof_attributes : attributes; - } - - and object_field_desc (*IF_CURRENT = Parsetree.object_field_desc *) = - | Otag of label loc * core_type - | Oinherit of core_type - - (* Patterns *) - - and pattern (*IF_CURRENT = Parsetree.pattern *) = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_loc_stack: location_stack; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Ppat_interval of constant * constant - (* 'a'..'z' - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (* (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Ppat_construct of Longident.t loc * (string loc list * pattern) option - (* C None - C P Some ([], P) - C (P1, ..., Pn) Some ([], Ppat_tuple [P1; ...; Pn]) - C (type a b) P Some ([a; b], P) - *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) - | Ppat_unpack of string option loc - (* (module P) Some "P" - (module _) None - - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of Longident.t loc * pattern - (* M.(P) *) - - (* Value expressions *) - - and expression (*IF_CURRENT = Parsetree.expression *) = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_loc_stack: location_stack; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = - | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) - | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_tuple of expression list - (* (E1, ..., En) - - Invariant: n >= 2 - *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) - | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) - | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * label loc - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of label loc * expression - (* x <- 2 *) - | Pexp_override of (label loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) - | Pexp_letmodule of string option loc * module_expr * expression - (* let module M = ME in E *) - | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) - | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) - | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string loc * expression - (* fun (type t) -> E *) - | Pexp_pack of module_expr - (* (module ME) - - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of open_declaration * expression - (* M.(E) - let open M in E - let! open M in E *) - | Pexp_letop of letop - (* let* P = E in E - let* P = E and* P = E in E *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable - (* . *) - - and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - - and letop (*IF_CURRENT = Parsetree.letop *) = - { - let_ : binding_op; - ands : binding_op list; - body : expression; - } - - and binding_op (*IF_CURRENT = Parsetree.binding_op *) = - { - pbop_op : string loc; - pbop_pat : pattern; - pbop_exp : expression; - pbop_loc : Location.t; - } - - (* Value descriptions *) - - and value_description (*IF_CURRENT = Parsetree.value_description *) = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } - -(* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) -*) - - (* Type declarations *) - - and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = - { - ptype_name: string loc; - ptype_params: (core_type * (variance * injectivity)) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } - -(* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) -*) - - and type_kind (*IF_CURRENT = Parsetree.type_kind *) = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) - | Ptype_open - - and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l : T [@id1] [@id2] *) - } - - (* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. - *) - - and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = - { - pcd_name: string loc; - pcd_vars: string loc list; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - -(* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) -*) - - and type_extension (*IF_CURRENT = Parsetree.type_extension *) = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * (variance * injectivity)) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_loc: Location.t; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } -(* - type t += ... -*) - - and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - (* exception E *) - and type_exception (*IF_CURRENT = Parsetree.type_exception *) = - { - ptyexn_constructor: extension_constructor; - ptyexn_loc: Location.t; - ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = - Pext_decl of string loc list * constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([], [T1; ...; Tn], None) - | C: T0 ([], [], Some T0) - | C: T1 * ... * Tn -> T0 ([], [T1; ...; Tn], Some T0) - | C: 'a... . T1... -> T0 (['a;...]; [T1;...], Some T0) - *) - | Pext_rebind of Longident.t loc - (* - | C = D - *) - - (** {1 Class language} *) - - (* Type expressions for the class language *) - - and class_type (*IF_CURRENT = Parsetree.class_type *) = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = - | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) - | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - | Pcty_open of open_description * class_type - (* let open M in CT *) - - and class_signature (*IF_CURRENT = Parsetree.class_signature *) = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } - (* object('selfpat) ... end - object ... end (self = Ptyp_any) - *) - - and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = - | Pctf_inherit of class_type - (* inherit CT *) - | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) - - and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = - { - pci_virt: virtual_flag; - pci_params: (core_type * (variance * injectivity)) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... - - Also used for "class type" declaration. - *) - - and class_description = class_type class_infos - - and class_type_declaration = class_type class_infos - - (* Value expressions for the class language *) - - and class_expr (*IF_CURRENT = Parsetree.class_expr *) = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = - | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - | Pcl_open of open_description * class_expr - (* let open M in CE *) - - - and class_structure (*IF_CURRENT = Parsetree.class_structure *) = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } - (* object(selfpat) ... end - object ... end (self = Ppat_any) - *) - - and class_field (*IF_CURRENT = Parsetree.class_field *) = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_field_desc (*IF_CURRENT = Parsetree.class_field_desc *) = - | Pcf_inherit of override_flag * class_expr * string loc option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) - | Pcf_val of (label loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) - | Pcf_method of (label loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) - - and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - - and class_declaration = class_expr class_infos - - (** {1 Module language} *) - - (* Type expressions for the module language *) - - and module_type (*IF_CURRENT = Parsetree.module_type *) = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) - | Pmty_functor of functor_parameter * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) - - and functor_parameter (*IF_CURRENT = Parsetree.functor_parameter *) = - | Unit - (* () *) - | Named of string option loc * module_type - (* (X : MT) Some X, MT - (_ : MT) None, MT *) - - and signature = signature_item list - - and signature_item (*IF_CURRENT = Parsetree.signature_item *) = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - - and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = - | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) - | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typesubst of type_declaration list - (* type t1 := ... and ... and tn := ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of type_exception - (* exception C of T *) - | Psig_module of module_declaration - (* module X = M - module X : MT *) - | Psig_modsubst of module_substitution - (* module X := M *) - | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) - | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_modtypesubst of module_type_declaration - (* module type S := ... *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) - | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) - - and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = - { - pmd_name: string option loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } - (* S : MT *) - - and module_substitution (*IF_CURRENT = Parsetree.module_substitution *) = - { - pms_name: string loc; - pms_manifest: Longident.t loc; - pms_attributes: attributes; (* ... [@@id1] [@@id2] *) - pms_loc: Location.t; - } - - and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } - (* S = MT - S (abstract module type declaration, pmtd_type = None) - *) - - and 'a open_infos (*IF_CURRENT = 'a Parsetree.open_infos *) = - { - popen_expr: 'a; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } - (* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) - - and open_description = Longident.t loc open_infos - (* open M.N - open M(N).O *) - - and open_declaration = module_expr open_infos - (* open M.N - open M(N).O - open struct ... end *) - - and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - - and include_description = module_type include_infos - (* include MT *) - - and include_declaration = module_expr include_infos - (* include ME *) - - and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = - | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) - | Pwith_modtype of Longident.t loc * module_type - (* with module type X.Y = Z *) - | Pwith_modtypesubst of Longident.t loc * module_type - (* with module type X.Y := sig end *) - | Pwith_typesubst of Longident.t loc * type_declaration - (* with type X.t := ..., same format as [Pwith_type] *) - | Pwith_modsubst of Longident.t loc * Longident.t loc - (* with module X.Y := Z *) - - (* Value expressions for the module language *) - - and module_expr (*IF_CURRENT = Parsetree.module_expr *) = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) - | Pmod_functor of functor_parameter * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) - - and structure = structure_item list - - and structure_item (*IF_CURRENT = Parsetree.structure_item *) = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - - and structure_item_desc (*IF_CURRENT = Parsetree.structure_item_desc *) = - | Pstr_eval of expression * attributes - (* E *) - | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) - | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) - | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) - | Pstr_exception of type_exception - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) - | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_declaration - (* open X *) - | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) - | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) - - and value_binding (*IF_CURRENT = Parsetree.value_binding *) = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - - and module_binding (*IF_CURRENT = Parsetree.module_binding *) = - { - pmb_name: string option loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } - (* X = ME *) - - (** {1 Toplevel} *) - - (* Toplevel phrases *) - - type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = - | Ptop_def of structure - | Ptop_dir of toplevel_directive - (* #use, #load ... *) - - and toplevel_directive (*IF_CURRENT = Parsetree.toplevel_directive *) = - { - pdir_name : string loc; - pdir_arg : directive_argument option; - pdir_loc : Location.t; - } - - and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = - { - pdira_desc : directive_argument_desc; - pdira_loc : Location.t; - } - - and directive_argument_desc (*IF_CURRENT = Parsetree.directive_argument_desc *) = - | Pdir_string of string - | Pdir_int of string * char option - | Pdir_ident of Longident.t - | Pdir_bool of bool -end - -module Docstrings: sig - (** Documentation comments - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - - *) - - (** (Re)Initialise all docstring state *) - val init : unit -> unit - - (** Emit warnings for unattached and ambiguous docstrings *) - val warn_bad_docstrings : unit -> unit - - (** {2 Docstrings} *) - - (** Documentation comments *) - type docstring - - (** Create a docstring *) - val docstring : string -> Location.t -> docstring - - (** Register a docstring *) - val register : docstring -> unit - - (** Get the text of a docstring *) - val docstring_body : docstring -> string - - (** Get the location of a docstring *) - val docstring_loc : docstring -> Location.t - - (** {2 Set functions} - - These functions are used by the lexer to associate docstrings to - the locations of tokens. *) - - (** Docstrings immediately preceding a token *) - val set_pre_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately following a token *) - val set_post_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings not immediately adjacent to a token *) - val set_floating_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately following the token which precedes this one *) - val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately preceding the token which follows this one *) - val set_post_extra_docstrings : Lexing.position -> docstring list -> unit - - (** {2 Items} - - The {!docs} type represents documentation attached to an item. *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - val empty_docs : docs - - val docs_attr : docstring -> Parsetree.attribute - - (** Convert item documentation to attributes and add them to an - attribute list *) - val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) - val symbol_docs : unit -> docs - val symbol_docs_lazy : unit -> docs Lazy.t - - (** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) - val rhs_docs : int -> int -> docs - val rhs_docs_lazy : int -> int -> docs Lazy.t - - (** Mark the item documentation for the current symbol (for ambiguity - warnings). *) - val mark_symbol_docs : unit -> unit - - (** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) - val mark_rhs_docs : int -> int -> unit - - (** {2 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - - type info = docstring option - - val empty_info : info - - val info_attr : docstring -> Parsetree.attribute - - (** Convert field info to attributes and add them to an - attribute list *) - val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the field info for the current symbol. *) - val symbol_info : unit -> info - - (** Fetch the field info following the symbol at a given position. *) - val rhs_info : int -> info - - (** {2 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - - type text = docstring list - - val empty_text : text - val empty_text_lazy : text Lazy.t - - val text_attr : docstring -> Parsetree.attribute - - (** Convert text to attributes and add them to an attribute list *) - val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the text preceding the current symbol. *) - val symbol_text : unit -> text - val symbol_text_lazy : unit -> text Lazy.t - - (** Fetch the text preceding the symbol at the given position. *) - val rhs_text : int -> text - val rhs_text_lazy : int -> text Lazy.t - - (** {2 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - - (** Fetch additional text preceding the current symbol *) - val symbol_pre_extra_text : unit -> text - - (** Fetch additional text following the current symbol *) - val symbol_post_extra_text : unit -> text - - (** Fetch additional text preceding the symbol at the given position *) - val rhs_pre_extra_text : int -> text - - (** Fetch additional text following the symbol at the given position *) - val rhs_post_extra_text : int -> text - - (** Fetch text following the symbol at the given position *) - val rhs_post_text : int -> text - - module WithMenhir: sig - (** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) - val symbol_docs : Lexing.position * Lexing.position -> docs - val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t - - (** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) - val rhs_docs : Lexing.position -> Lexing.position -> docs - val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t - - (** Mark the item documentation for the current symbol (for ambiguity - warnings). *) - val mark_symbol_docs : Lexing.position * Lexing.position -> unit - - (** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) - val mark_rhs_docs : Lexing.position -> Lexing.position -> unit - - (** Fetch the field info for the current symbol. *) - val symbol_info : Lexing.position -> info - - (** Fetch the field info following the symbol at a given position. *) - val rhs_info : Lexing.position -> info - - (** Fetch the text preceding the current symbol. *) - val symbol_text : Lexing.position -> text - val symbol_text_lazy : Lexing.position -> text Lazy.t - - (** Fetch the text preceding the symbol at the given position. *) - val rhs_text : Lexing.position -> text - val rhs_text_lazy : Lexing.position -> text Lazy.t - - (** {3 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - - (** Fetch additional text preceding the current symbol *) - val symbol_pre_extra_text : Lexing.position -> text - - (** Fetch additional text following the current symbol *) - val symbol_post_extra_text : Lexing.position -> text - - (** Fetch additional text preceding the symbol at the given position *) - val rhs_pre_extra_text : Lexing.position -> text - - (** Fetch additional text following the symbol at the given position *) - val rhs_post_extra_text : Lexing.position -> text - - (** Fetch text following the symbol at the given position *) - val rhs_post_text : Lexing.position -> text - - end -end = struct - open Location - - (* Docstrings *) - - (* A docstring is "attached" if it has been inserted in the AST. This - is used for generating unexpected docstring warnings. *) - type ds_attached = - | Unattached (* Not yet attached anything.*) - | Info (* Attached to a field or constructor. *) - | Docs (* Attached to an item or as floating text. *) - - (* A docstring is "associated" with an item if there are no blank lines between - them. This is used for generating docstring ambiguity warnings. *) - type ds_associated = - | Zero (* Not associated with an item *) - | One (* Associated with one item *) - | Many (* Associated with multiple items (ambiguity) *) - - type docstring = - { ds_body: string; - ds_loc: Location.t; - mutable ds_attached: ds_attached; - mutable ds_associated: ds_associated; } - - (* List of docstrings *) - - let docstrings : docstring list ref = ref [] - - (* Warn for unused and ambiguous docstrings *) - - let warn_bad_docstrings () = - if Warnings.is_active (Migrate_parsetree_compiler_functions.bad_docstring true) then begin - List.iter - (fun ds -> - match ds.ds_attached with - | Info -> () - | Unattached -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring true) - | Docs -> - match ds.ds_associated with - | Zero | One -> () - | Many -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring true)) - (List.rev !docstrings) - end - - (* Docstring constructors and destructors *) - - let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; - ds_attached = Unattached; - ds_associated = Zero; } - in - ds - - let register ds = - docstrings := ds :: !docstrings - - let docstring_body ds = ds.ds_body - - let docstring_loc ds = ds.ds_loc - - (* Docstrings attached to items *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - let empty_docs = { docs_pre = None; docs_post = None } - - let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - - let docs_attr ds = - let open Parsetree in - let body = ds.ds_body in - let loc = ds.ds_loc in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } - in - { attr_name = doc_loc; - attr_payload = PStr [item]; - attr_loc = loc } - - let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - - (* Docstrings attached to constructors or fields *) - - type info = docstring option - - let empty_info = None - - let info_attr = docs_attr - - let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - - (* Docstrings not attached to a specific item *) - - type text = docstring list - - let empty_text = [] - let empty_text_lazy = lazy [] - - let text_loc = {txt = "ocaml.text"; loc = Location.none} - - let text_attr ds = - let open Parsetree in - let body = ds.ds_body in - let loc = ds.ds_loc in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } - in - { attr_name = text_loc; - attr_payload = PStr [item]; - attr_loc = loc } - - let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - - (* Find the first non-info docstring in a list, attach it and return it *) - let get_docstring ~info dsl = - let rec loop = function - | [] -> None - | {ds_attached = Info; _} :: rest -> loop rest - | ds :: _ -> - ds.ds_attached <- if info then Info else Docs; - Some ds - in - loop dsl - - (* Find all the non-info docstrings in a list, attach them and return them *) - let get_docstrings dsl = - let rec loop acc = function - | [] -> List.rev acc - | {ds_attached = Info; _} :: rest -> loop acc rest - | ds :: rest -> - ds.ds_attached <- Docs; - loop (ds :: acc) rest - in - loop [] dsl - - (* "Associate" all the docstrings in a list *) - let associate_docstrings dsl = - List.iter - (fun ds -> - match ds.ds_associated with - | Zero -> ds.ds_associated <- One - | (One | Many) -> ds.ds_associated <- Many) - dsl - - (* Map from positions to pre docstrings *) - - let pre_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_pre_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_table pos dsl - - let get_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - - let mark_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl - with Not_found -> () - - (* Map from positions to post docstrings *) - - let post_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_post_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_table pos dsl - - let get_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - - let mark_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl - with Not_found -> () - - let get_info pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstring ~info:true dsl - with Not_found -> None - - (* Map from positions to floating docstrings *) - - let floating_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_floating_docstrings pos dsl = - if dsl <> [] then Hashtbl.add floating_table pos dsl - - let get_text pos = - try - let dsl = Hashtbl.find floating_table pos in - get_docstrings dsl - with Not_found -> [] - - let get_post_text pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstrings dsl - with Not_found -> [] - - (* Maps from positions to extra docstrings *) - - let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_pre_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_extra_table pos dsl - - let get_pre_extra_text pos = - try - let dsl = Hashtbl.find pre_extra_table pos in - get_docstrings dsl - with Not_found -> [] - - let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_post_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_extra_table pos dsl - - let get_post_extra_text pos = - try - let dsl = Hashtbl.find post_extra_table pos in - get_docstrings dsl - with Not_found -> [] - - (* Docstrings from parser actions *) - module WithParsing = struct - let symbol_docs () = - { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); - docs_post = get_post_docs (Parsing.symbol_end_pos ()); } - - let symbol_docs_lazy () = - let p1 = Parsing.symbol_start_pos () in - let p2 = Parsing.symbol_end_pos () in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); - docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } - - let rhs_docs_lazy pos1 pos2 = - let p1 = Parsing.rhs_start_pos pos1 in - let p2 = Parsing.rhs_end_pos pos2 in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let mark_symbol_docs () = - mark_pre_docs (Parsing.symbol_start_pos ()); - mark_post_docs (Parsing.symbol_end_pos ()) - - let mark_rhs_docs pos1 pos2 = - mark_pre_docs (Parsing.rhs_start_pos pos1); - mark_post_docs (Parsing.rhs_end_pos pos2) - - let symbol_info () = - get_info (Parsing.symbol_end_pos ()) - - let rhs_info pos = - get_info (Parsing.rhs_end_pos pos) - - let symbol_text () = - get_text (Parsing.symbol_start_pos ()) - - let symbol_text_lazy () = - let pos = Parsing.symbol_start_pos () in - lazy (get_text pos) - - let rhs_text pos = - get_text (Parsing.rhs_start_pos pos) - - let rhs_post_text pos = - get_post_text (Parsing.rhs_end_pos pos) - - let rhs_text_lazy pos = - let pos = Parsing.rhs_start_pos pos in - lazy (get_text pos) - - let symbol_pre_extra_text () = - get_pre_extra_text (Parsing.symbol_start_pos ()) - - let symbol_post_extra_text () = - get_post_extra_text (Parsing.symbol_end_pos ()) - - let rhs_pre_extra_text pos = - get_pre_extra_text (Parsing.rhs_start_pos pos) - - let rhs_post_extra_text pos = - get_post_extra_text (Parsing.rhs_end_pos pos) - end - - include WithParsing - - module WithMenhir = struct - let symbol_docs (startpos, endpos) = - { docs_pre = get_pre_docs startpos; - docs_post = get_post_docs endpos; } - - let symbol_docs_lazy (p1, p2) = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs pos1; - docs_post = get_post_docs pos2; } - - let rhs_docs_lazy p1 p2 = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let mark_symbol_docs (startpos, endpos) = - mark_pre_docs startpos; - mark_post_docs endpos; - () - - let mark_rhs_docs pos1 pos2 = - mark_pre_docs pos1; - mark_post_docs pos2; - () - - let symbol_info endpos = - get_info endpos - - let rhs_info endpos = - get_info endpos - - let symbol_text startpos = - get_text startpos - - let symbol_text_lazy startpos = - lazy (get_text startpos) - - let rhs_text pos = - get_text pos - - let rhs_post_text pos = - get_post_text pos - - let rhs_text_lazy pos = - lazy (get_text pos) - - let symbol_pre_extra_text startpos = - get_pre_extra_text startpos - - let symbol_post_extra_text endpos = - get_post_extra_text endpos - - let rhs_pre_extra_text pos = - get_pre_extra_text pos - - let rhs_post_extra_text pos = - get_post_extra_text pos - end - - (* (Re)Initialise all comment state *) - - let init () = - docstrings := []; - Hashtbl.reset pre_table; - Hashtbl.reset post_table; - Hashtbl.reset floating_table; - Hashtbl.reset pre_extra_table; - Hashtbl.reset post_extra_table -end -module Ast_helper: sig - (** Helpers to produce Parsetree fragments - - {b Warning} This module is unstable and part of - {{!Compiler_libs}compiler-libs}. - - *) - - open Asttypes - open Docstrings - open Parsetree - - type 'a with_loc = 'a Location.loc - type loc = Location.t - - type lid = Longident.t with_loc - type str = string with_loc - type str_opt = string option with_loc - type attrs = attribute list - - (** {1 Default locations} *) - - val default_loc: loc ref - (** Default value for all optional location arguments. *) - - val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - - (** {1 Constants} *) - - module Const : sig - val char : char -> constant - val string : - ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant - end - - (** {1 Attributes} *) - module Attr : sig - val mk: ?loc:loc -> str -> payload -> attribute - end - - (** {1 Core language} *) - - (** Type expressions *) - module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - - (** Patterns *) - module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> - lid -> (str list * pattern) option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - - (** Expressions *) - module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr - -> expression -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression - -> expression - val letop: ?loc:loc -> ?attrs:attrs -> binding_op - -> binding_op list -> expression -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - val binding_op: str -> pattern -> expression -> loc -> binding_op - end - - (** Value declarations *) - module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - - (** Type declarations *) - module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * (variance * injectivity)) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> - str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - - (** Type extensions *) - module Te: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * (variance * injectivity)) list -> - ?priv:private_flag -> lid -> extension_constructor list -> type_extension - - val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - extension_constructor -> type_exception - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> - str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - - (** {1 Module language} *) - - (** Module type expressions *) - module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - - (** Module expressions *) - module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - - (** Signature items *) - module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_subst: ?loc:loc -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> type_exception -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val mod_subst: ?loc:loc -> module_substitution -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val modtype_subst: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - - (** Structure items *) - module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> type_exception -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_declaration -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - - (** Module declarations *) - module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_type -> module_declaration - end - - (** Module substitutions *) - module Ms: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> lid -> module_substitution - end - - (** Module type declarations *) - module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - - (** Module bindings *) - module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_expr -> module_binding - end - - (** Opens *) - module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> 'a -> 'a open_infos - end - - (** Includes *) - module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - - (** Value bindings *) - module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - - (** {1 Class language} *) - - (** Class type expressions *) - module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type - -> class_type - end - - (** Class type fields *) - module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - - (** Class expressions *) - module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr - -> class_expr - end - - (** Class fields *) - module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - - (** Classes *) - module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> - ?params:(core_type * (variance * injectivity)) list -> - str -> 'a -> 'a class_infos - end - - (** Class signatures *) - module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - - (** Class structures *) - module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - - (** Row fields *) - module Rf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> bool -> core_type list -> row_field - val inherit_: ?loc:loc -> core_type -> row_field - end - - (** Object fields *) - module Of: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - object_field_desc -> object_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> core_type -> object_field - val inherit_: ?loc:loc -> core_type -> object_field - end -end = struct - (** Helpers to produce Parsetree fragments *) - - open Asttypes - open Parsetree - open Docstrings - - type 'a with_loc = 'a Location.loc - type loc = Location.t - - type lid = Longident.t with_loc - type str = string with_loc - type str_opt = string option with_loc - type attrs = attribute list - - let default_loc = ref Location.none - - let with_default_loc l f = - Misc.protect_refs [Misc.R (default_loc, l)] f - - module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (string_of_int i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter ?(loc= !default_loc) s = - Pconst_string (s, loc, quotation_delimiter) - end - - module Attr = struct - let mk ?(loc= !default_loc) name payload = - { attr_name = name; - attr_payload = payload; - attr_loc = loc } - end - - module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; - ptyp_loc = loc; - ptyp_loc_stack = []; - ptyp_attributes = attrs} - - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - - let varify_constructors var_names t = - let check_variable vl loc v = - if List.mem v vl then - raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in - let var_names = List.map (fun v -> v.txt) var_names in - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> - check_variable var_names t.ptyp_loc x; - Ptyp_var x - | Ptyp_arrow (label,core_type,core_type') -> - Ptyp_arrow(label, loop core_type, loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr( { txt = Longident.Lident s }, []) - when List.mem s var_names -> - Ptyp_var s - | Ptyp_constr(longident, lst) -> - Ptyp_constr(longident, List.map loop lst) - | Ptyp_object (lst, o) -> - Ptyp_object (List.map loop_object_field lst, o) - | Ptyp_class (longident, lst) -> - Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) - in - {t with ptyp_desc = desc} - and loop_row_field field = - let prf_desc = match field.prf_desc with - | Rtag(label,flag,lst) -> - Rtag(label,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - in - { field with prf_desc; } - and loop_object_field field = - let pof_desc = match field.pof_desc with - | Otag(label, t) -> - Otag(label, loop t) - | Oinherit t -> - Oinherit (loop t) - in - { field with pof_desc; } - in - loop t - - end - - module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; - ppat_loc = loc; - ppat_loc_stack = []; - ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) - end - - module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b)) - let letop ?loc ?attrs let_ ands body = - mk ?loc ?attrs (Pexp_letop {let_; ands; body}) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - - let binding_op op pat exp loc = - { - pbop_op = op; - pbop_pat = pat; - pbop_exp = exp; - pbop_loc = loc; - } - end - - module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) - end - - module Mod = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg body = - mk ?loc ?attrs (Pmod_functor (arg, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) - end - - module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_subst ?loc a = mk ?loc (Psig_typesubst a) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let mod_subst ?loc a = mk ?loc (Psig_modsubst a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let modtype_subst ?loc a = mk ?loc (Psig_modtypesubst a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b)) - end - - module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b)) - end - - module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - - end - - module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - - end - - module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } - end - - module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } - end - - module Ms = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name syn = - { - pms_name = name; - pms_manifest = syn; - pms_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pms_loc = loc; - } - end - - module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } - end - - module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } - end - - module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) expr = - { - popen_expr = expr; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } - end - - module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - - end - - module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } - end - - module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } - end - - module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(vars = []) ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_vars = vars; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - - end - - (** Type extensions *) - module Te = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_loc = loc; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - constructor = - { - ptyexn_constructor = constructor; - ptyexn_loc = loc; - ptyexn_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(vars = []) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(vars, args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - end - - module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } - end - - module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } - end - - (** Row fields *) - module Rf = struct - let mk ?(loc = !default_loc) ?(attrs = []) desc = { - prf_desc = desc; - prf_loc = loc; - prf_attributes = attrs; - } - let tag ?loc ?attrs label const tys = - mk ?loc ?attrs (Rtag (label, const, tys)) - let inherit_?loc ty = - mk ?loc (Rinherit ty) - end - - (** Object fields *) - module Of = struct - let mk ?(loc = !default_loc) ?(attrs=[]) desc = { - pof_desc = desc; - pof_loc = loc; - pof_attributes = attrs; - } - let tag ?loc ?attrs label ty = - mk ?loc ?attrs (Otag (label, ty)) - let inherit_ ?loc ty = - mk ?loc (Oinherit ty) - end -end -module Ast_mapper: sig - (** The interface of a -ppx rewriter - - A -ppx rewriter is a program that accepts a serialized abstract syntax - tree and outputs another, possibly modified, abstract syntax tree. - This module encapsulates the interface between the compiler and - the -ppx rewriters, handling such details as the serialization format, - forwarding of command-line flags, and storing state. - - {!mapper} enables AST rewriting using open recursion. - A typical mapper would be based on {!default_mapper}, a deep - identity mapper, and will fall back on it for handling the syntax it - does not modify. For example: - - {[ - open Asttypes - open Parsetree - open Ast_mapper - - let test_mapper argv = - { default_mapper with - expr = fun mapper expr -> - match expr with - | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> - Ast_helper.Exp.constant (Const_int 42) - | other -> default_mapper.expr mapper other; } - - let () = - register "ppx_test" test_mapper]} - - This -ppx rewriter, which replaces [[%test]] in expressions with - the constant [42], can be compiled using - [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - - *) - - open Parsetree - - (** {1 A generic Parsetree mapper} *) - - type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - (** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - - val default_mapper: mapper - (** A default mapper, which implements a "deep identity" mapping. *) - - (** {1 Apply mappers to compilation units} *) - - val tool_name: unit -> string - (** Can be used within a ppx preprocessor to know which tool is - calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], - ["ocaml"], ... Some global variables that reflect command-line - options are automatically synchronized between the calling tool - and the ppx preprocessor: {!Clflags.include_dirs}, - {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package}, - {!Clflags.debug}. *) - - - val apply: source:string -> target:string -> mapper -> unit - (** Apply a mapper (parametrized by the unit name) to a dumped - parsetree found in the [source] file and put the result in the - [target] file. The [structure] or [signature] field of the mapper - is applied to the implementation or interface. *) - - val run_main: (string list -> mapper) -> unit - (** Entry point to call to implement a standalone -ppx rewriter from a - mapper, parametrized by the command line arguments. The current - unit name can be obtained from {!Location.input_name}. This - function implements proper error reporting for uncaught - exceptions. *) - - (** {1 Registration API} *) - - val register_function: (string -> (string list -> mapper) -> unit) ref - - val register: string -> (string list -> mapper) -> unit - (** Apply the [register_function]. The default behavior is to run the - mapper immediately, taking arguments from the process command - line. This is to support a scenario where a mapper is linked as a - stand-alone executable. - - It is possible to overwrite the [register_function] to define - "-ppx drivers", which combine several mappers in a single process. - Typically, a driver starts by defining [register_function] to a - custom implementation, then lets ppx rewriters (linked statically - or dynamically) register themselves, and then run all or some of - them. It is also possible to have -ppx drivers apply rewriters to - only specific parts of an AST. - - The first argument to [register] is a symbolic name to be used by - the ppx driver. *) - - - (** {1 Convenience functions to write mappers} *) - - val map_opt: ('a -> 'b) -> 'a option -> 'b option - - val extension_of_error: Location.error -> extension - (** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) - - val attribute_of_warning: Location.t -> string -> attribute - (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) - - (** {1 Helper functions to call external mappers} *) - - val add_ppx_context_str: - tool_name:string -> Parsetree.structure -> Parsetree.structure - (** Extract information from the current environment and encode it - into an attribute which is prepended to the list of structure - items in order to pass the information to an external - processor. *) +module Asttypes = struct + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * Location.t * string option + | Const_float of string + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint - val add_ppx_context_sig: - tool_name:string -> Parsetree.signature -> Parsetree.signature - (** Same as [add_ppx_context_str], but for signatures. *) + type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive - val drop_ppx_context_str: - restore:bool -> Parsetree.structure -> Parsetree.structure - (** Drop the ocaml.ppx.context attribute from a structure. If - [restore] is true, also restore the associated data in the current - process. *) + type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto - val drop_ppx_context_sig: - restore:bool -> Parsetree.signature -> Parsetree.signature - (** Same as [drop_ppx_context_str], but for signatures. *) + (* Order matters, used in polymorphic comparison *) + type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - (** {1 Cookies} *) + type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - (** Cookies are used to pass information from a ppx processor to - a further invocation of itself, when called from the OCaml - toplevel (or other tools that support cookies). *) + type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - val set_cookie: string -> Parsetree.expression -> unit - val get_cookie: string -> Parsetree.expression option - end = struct - (* A generic Parsetree mapping class *) + type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh - (* - [@@@ocaml.warning "+9"] - (* Ensure that record patterns don't miss any field. *) - *) + type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open - open Parsetree - open Ast_helper - open Location + type label = string - module String = Misc.Stdlib.String + type arg_label (*IF_CURRENT = Asttypes.arg_label *) = + Nolabel + | Labelled of string (* label:T -> ... *) + | Optional of string (* ?label:T -> ... *) - type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; + type 'a loc = 'a Location.loc = { + txt : 'a; + loc : Location.t; } - let map_fst f (x, y) = (f x, y) - let map_snd f (x, y) = (x, f y) - let map_tuple f1 f2 (x, y) = (f1 x, f2 y) - let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) - let map_opt f = function None -> None | Some x -> Some (f x) - - let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - - module C = struct - (* Constants *) - - let map sub c = match c with - | Pconst_integer _ - | Pconst_char _ - | Pconst_float _ - -> c - | Pconst_string (s, loc, quotation_delimiter) -> - let loc = sub.location sub loc in - Const.string ~loc ?quotation_delimiter s - end - - module T = struct - (* Type expressions for the core language *) - - let row_field sub { - prf_desc; - prf_loc; - prf_attributes; - } = - let loc = sub.location sub prf_loc in - let attrs = sub.attributes sub prf_attributes in - let desc = match prf_desc with - | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - in - Rf.mk ~loc ~attrs desc - - let object_field sub { - pof_desc; - pof_loc; - pof_attributes; - } = - let loc = sub.location sub pof_loc in - let attrs = sub.attributes sub pof_attributes in - let desc = match pof_desc with - | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t) - | Oinherit t -> Oinherit (sub.typ sub t) - in - Of.mk ~loc ~attrs desc - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs - (List.map (map_loc sub) sl) (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - let loc = sub.location sub ptype_loc in - let attrs = sub.attributes sub ptype_attributes in - Type.mk ~loc ~attrs (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_loc; - ptyext_attributes} = - let loc = sub.location sub ptyext_loc in - let attrs = sub.attributes sub ptyext_attributes in - Te.mk ~loc ~attrs - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - - let map_type_exception sub - {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = - let loc = sub.location sub ptyexn_loc in - let attrs = sub.attributes sub ptyexn_attributes in - Te.mk_exception ~loc ~attrs - (sub.extension_constructor sub ptyexn_constructor) - - let map_extension_constructor_kind sub = function - Pext_decl(vars, ctl, cto) -> - Pext_decl(List.map (map_loc sub) vars, - map_constructor_arguments sub ctl, - map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - let loc = sub.location sub pext_loc in - let attrs = sub.attributes sub pext_attributes in - Te.constructor ~loc ~attrs - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - - end - - module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (o, ct) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) - end - - let map_functor_param sub = function - | Unit -> Unit - | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt) - - module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (param, mt) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_type sub mt) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_modtype (lid, mty) -> - Pwith_modtype (map_loc sub lid, sub.module_type sub mty) - | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - | Pwith_modtypesubst (lid, mty) -> - Pwith_modtypesubst (map_loc sub lid, sub.module_type sub mty) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> - type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typesubst l -> - type_subst ~loc (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_modtypesubst x -> - modtype_subst ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) - end - - - module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (param, body) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - let attrs = sub.attributes sub attrs in - eval ~loc ~attrs (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_declaration sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) - end - - module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x) - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> - send ~loc ~attrs (sub.expr sub e) (map_loc sub s) - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (o, e) -> - open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e) - | Pexp_letop {let_; ands; body} -> - letop ~loc ~attrs (sub.binding_op sub let_) - (List.map (sub.binding_op sub) ands) (sub.expr sub body) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () - - let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = - let open Exp in - let op = map_loc sub pbop_op in - let pat = sub.pat sub pbop_pat in - let exp = sub.expr sub pbop_exp in - let loc = sub.location sub pbop_loc in - binding_op op pat exp loc - - end - - module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs (sub.constant sub c) - | Ppat_interval (c1, c2) -> - interval ~loc ~attrs (sub.constant sub c1) (sub.constant sub c2) - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) - (map_opt - (fun (vl, p) -> List.map (map_loc sub) vl, sub.pat sub p) - p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) - end - - module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (o, ce) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> - inherit_ ~loc ~attrs o (sub.class_expr sub ce) - (map_opt (map_loc sub) s) - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - let loc = sub.location sub pci_loc in - let attrs = sub.attributes sub pci_attributes in - Ci.mk ~loc ~attrs - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) - end - - (* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - - let default_mapper = - { - constant = C.map; - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - type_exception = T.map_type_exception; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - binding_op = E.map_binding_op; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_substitution = - (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> - Ms.mk - (map_loc this pms_name) - (map_loc this pms_manifest) - ~attrs:(this.attributes this pms_attributes) - ~loc:(this.location this pms_loc) - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_declaration = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (this.module_expr this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - open_description = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_vars; pcd_args; - pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~vars:(List.map (map_loc this) pcd_vars) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this a -> - { - attr_name = map_loc this a.attr_name; - attr_payload = this.payload this a.attr_payload; - attr_loc = this.location this a.attr_loc - } - ); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - - let extension_of_error error = - Locations.extension_of_error - ~mk_pstr:(fun x -> PStr x) - ~mk_extension:(fun x -> Str.extension x) - ~mk_string_constant:(fun x -> Str.eval (Exp.constant (Pconst_string (x, Location.none (* XXX *), None)))) - error - - let attribute_of_warning loc s = - Attr.mk - {loc; txt = "ocaml.ppwarning" } - (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, loc, None)))])) - - let cookies = ref String.Map.empty - - let get_cookie k = - try Some (String.Map.find k !cookies) - with Not_found -> None - - let set_cookie k v = - cookies := String.Map.add k v !cookies - - let tool_name_ref = ref "_none_" - - let tool_name () = !tool_name_ref - - - module PpxContext = struct - open Longident - open Asttypes - open Ast_helper - - let lid name = { txt = Lident name; loc = Location.none } - - let make_string s = Exp.constant (Const.string s) - - let make_bool x = - if x - then Exp.construct (lid "true") None - else Exp.construct (lid "false") None - - let rec make_list f lst = - match lst with - | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) - | [] -> - Exp.construct (lid "[]") None - - let make_pair f1 f2 (x1, x2) = - Exp.tuple [f1 x1; f2 x2] - - let make_option f opt = - match opt with - | Some x -> Exp.construct (lid "Some") (Some (f x)) - | None -> Exp.construct (lid "None") None - - let get_cookies () = - lid "cookies", - make_list (make_pair make_string (fun x -> x)) - (String.Map.bindings !cookies) - - let mk fields = - { - attr_name = { txt = "ocaml.ppx.context"; loc = Location.none }; - attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)]; - attr_loc = Location.none - } - - let make ~tool_name () = - let fields = - [ - lid "tool_name", make_string tool_name; - lid "include_dirs", make_list make_string !Clflags.include_dirs; - lid "load_path", make_list make_string (Migrate_parsetree_compiler_functions.get_load_paths ()); - lid "open_modules", make_list make_string !Clflags.open_modules; - lid "for_package", make_option make_string !Clflags.for_package; - lid "debug", make_bool !Clflags.debug; - lid "use_threads", make_bool !Clflags.use_threads; - lid "use_vmthreads", make_bool false; - lid "recursive_types", make_bool !Clflags.recursive_types; - lid "principal", make_bool !Clflags.principal; - lid "transparent_modules", make_bool !Clflags.transparent_modules; - lid "unboxed_types", make_bool (Migrate_parsetree_compiler_functions.get_unboxed_types ()); - get_cookies () - ] - in - mk fields - - let get_fields = function - | PStr [{pstr_desc = Pstr_eval - ({ pexp_desc = Pexp_record (fields, None) }, [])}] -> - fields - | _ -> - raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" - - let restore fields = - let field name payload = - let rec get_string = function - | { pexp_desc = Pexp_constant (Pconst_string (str, _, None)) } -> str - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] string syntax" name - and get_bool pexp = - match pexp with - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, - None)} -> - true - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, - None)} -> - false - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] bool syntax" name - and get_list elem = function - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> - elem exp :: get_list elem rest - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> - [] - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] list syntax" name - and get_pair f1 f2 = function - | {pexp_desc = Pexp_tuple [e1; e2]} -> - (f1 e1, f2 e2) - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] pair syntax" name - and get_option elem = function - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> - Some (elem exp) - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> - None - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] option syntax" name - in - match name with - | "tool_name" -> - tool_name_ref := get_string payload - | "include_dirs" -> - Clflags.include_dirs := get_list get_string payload - | "load_path" -> - Migrate_parsetree_compiler_functions.load_path_init (get_list get_string payload) - | "open_modules" -> - Clflags.open_modules := get_list get_string payload - | "for_package" -> - Clflags.for_package := get_option get_string payload - | "debug" -> - Clflags.debug := get_bool payload - | "use_threads" -> - Clflags.use_threads := get_bool payload - | "use_vmthreads" -> - if get_bool payload then - raise_errorf "Internal error: vmthreads not supported after 4.09.0" - | "recursive_types" -> - Clflags.recursive_types := get_bool payload - | "principal" -> - Clflags.principal := get_bool payload - | "transparent_modules" -> - Clflags.transparent_modules := get_bool payload - | "unboxed_types" -> - Migrate_parsetree_compiler_functions.set_unboxed_types (get_bool payload) - | "cookies" -> - let l = get_list (get_pair get_string (fun x -> x)) payload in - cookies := - List.fold_left - (fun s (k, v) -> String.Map.add k v s) String.Map.empty - l - | _ -> - () - in - List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields - - let update_cookies fields = - let fields = - List.filter - (function ({txt=Lident "cookies"}, _) -> false | _ -> true) - fields - in - fields @ [get_cookies ()] - end - - let ppx_context = PpxContext.make - - let extension_of_exn exn = extension_of_error (Locations.location_error_of_exn exn) - (* let extension_of_exn exn = *) - (* match error_of_exn exn with *) - (* | Some (`Ok error) -> extension_of_error error *) - (* | Some `Already_displayed -> *) - (* { loc = Location.none; txt = "ocaml.error" }, PStr [] *) - (* | None -> raise exn *) - - let apply_lazy ~source ~target mapper = - let implem ast = - let fields, ast = - match ast with - | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.structure mapper ast - with exn -> - [{pstr_desc = Pstr_extension (extension_of_exn exn, []); - pstr_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Str.attribute (PpxContext.mk fields) :: ast - in - let iface ast = - let fields, ast = - match ast with - | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x; - attr_loc = _})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.signature mapper ast - with exn -> - [{psig_desc = Psig_extension (extension_of_exn exn, []); - psig_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Sig.attribute (PpxContext.mk fields) :: ast - in - - let ic = open_in_bin source in - let magic = - really_input_string ic (String.length Config.ast_impl_magic_number) - in - - let rewrite transform = - Location.input_name := input_value ic; - let ast = input_value ic in - close_in ic; - let ast = transform ast in - let oc = open_out_bin target in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc - and fail () = - close_in ic; - failwith "Ast_mapper: OCaml version mismatch or malformed input"; - in - - if magic = Config.ast_impl_magic_number then - rewrite (implem : structure -> structure) - else if magic = Config.ast_intf_magic_number then - rewrite (iface : signature -> signature) - else fail () - - let drop_ppx_context_str ~restore = function - | {pstr_desc = Pstr_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - - let drop_ppx_context_sig ~restore = function - | {psig_desc = Psig_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - - let add_ppx_context_str ~tool_name ast = - Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast - - let add_ppx_context_sig ~tool_name ast = - Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast - - - let apply ~source ~target mapper = - apply_lazy ~source ~target (fun () -> mapper) - - let run_main mapper = - try - let a = Sys.argv in - let n = Array.length a in - if n > 2 then - let mapper () = - try mapper (Array.to_list (Array.sub a 1 (n - 3))) - with exn -> - (* PR#6463 *) - let f _ _ = raise exn in - {default_mapper with structure = f; signature = f} - in - apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper - else begin - Printf.eprintf "Usage: %s [extra_args] \n%!" - Sys.executable_name; - exit 2 - end - with exn -> - prerr_endline (Printexc.to_string exn); - exit 2 + type variance (*IF_CURRENT = Asttypes.variance *) = + | Covariant + | Contravariant + | NoVariance - let register_function = ref (fun _name f -> run_main f) - let register name f = !register_function name f + type injectivity (*IF_CURRENT = Asttypes.injectivity *) = + | Injective + | NoInjectivity end + module Type_immediacy = struct type t (*IF_CURRENT = Type_immediacy.t *) = | Unknown | Always | Always_on_64bits end + module Outcometree = struct (* Module [Outcometree]: results displayed by the toplevel *) @@ -4163,121 +214,3 @@ module Outcometree = struct | Ophr_signature of (out_sig_item * out_value option) list | Ophr_exception of (exn * out_value) end -module Config = struct - let ast_impl_magic_number = "Caml1999M031" - let ast_intf_magic_number = "Caml1999N031" -end - - - -let map_signature mapper = mapper.Ast_mapper.signature mapper -let map_structure mapper = mapper.Ast_mapper.structure mapper - -let shallow_identity = - let id _ x = x in - { - Ast_mapper. - structure = id; - structure_item = id; - module_expr = id; - signature = id; - signature_item = id; - module_type = id; - with_constraint = id; - class_declaration = id; - class_expr = id; - class_field = id; - class_structure = id; - class_type = id; - class_type_field = id; - class_signature = id; - class_type_declaration = id; - class_description = id; - type_declaration = id; - type_kind = id; - typ = id; - type_extension = id; - extension_constructor = id; - value_description = id; - pat = id; - expr = id; - module_declaration = id; - module_type_declaration = id; - module_binding = id; - open_description = id; - include_description = id; - include_declaration = id; - value_binding = id; - constructor_declaration = id; - label_declaration = id; - cases = id; - case = id; - location = id; - extension = id; - attribute = id; - attributes = id; - payload = id; - binding_op = id; - module_substitution = id; - open_declaration = id; - type_exception = id; - constant = id; - } - -let failing_mapper = - let fail _ _ = - invalid_arg "failing_mapper: this mapper function should never get called" - in - { - Ast_mapper. - structure = fail; - structure_item = fail; - module_expr = fail; - signature = fail; - signature_item = fail; - module_type = fail; - with_constraint = fail; - class_declaration = fail; - class_expr = fail; - class_field = fail; - class_structure = fail; - class_type = fail; - class_type_field = fail; - class_signature = fail; - class_type_declaration = fail; - class_description = fail; - type_declaration = fail; - type_kind = fail; - typ = fail; - type_extension = fail; - extension_constructor = fail; - value_description = fail; - pat = fail; - expr = fail; - module_declaration = fail; - module_type_declaration = fail; - module_binding = fail; - open_description = fail; - include_description = fail; - include_declaration = fail; - value_binding = fail; - constructor_declaration = fail; - label_declaration = fail; - cases = fail; - case = fail; - location = fail; - extension = fail; - attribute = fail; - attributes = fail; - payload = fail; - binding_op = fail; - module_substitution = fail; - open_declaration = fail; - type_exception = fail; - constant = fail; - } - -let make_top_mapper ~signature ~structure = - {failing_mapper with Ast_mapper. - signature = (fun _ x -> signature x); - structure = (fun _ x -> structure x) } diff --git a/src/vendored-omp/src/ast_500.ml b/src/vendored-omp/src/ast_500.ml index 314246bc9..02aff7c32 100644 --- a/src/vendored-omp/src/ast_500.ml +++ b/src/vendored-omp/src/ast_500.ml @@ -17,4009 +17,60 @@ (* *) (**************************************************************************) -open Ast_409_helper - -module Asttypes = struct - type constant (*IF_CURRENT = Asttypes.constant *) = - Const_int of int - | Const_char of char - | Const_string of string * Location.t * string option - | Const_float of string - | Const_int32 of int32 - | Const_int64 of int64 - | Const_nativeint of nativeint - - type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive - - type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto - - (* Order matters, used in polymorphic comparison *) - type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - - type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - - type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - - type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh - - type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open - - type label = string - - type arg_label (*IF_CURRENT = Asttypes.arg_label *) = - Nolabel - | Labelled of string (* label:T -> ... *) - | Optional of string (* ?label:T -> ... *) - - type 'a loc = 'a Location.loc = { - txt : 'a; - loc : Location.t; - } - - type variance (*IF_CURRENT = Asttypes.variance *) = - | Covariant - | Contravariant - | NoVariance - - type injectivity (*IF_CURRENT = Asttypes.injectivity *) = - | Injective - | NoInjectivity -end - -module Parsetree = struct - open Asttypes - - type constant (*IF_CURRENT = Parsetree.constant *) = - Pconst_integer of string * char option - (* 3 3l 3L 3n - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' and 'n' are rejected by the typechecker - *) - | Pconst_char of char - (* 'c' *) - | Pconst_string of string * Location.t * string option - (* "constant" - {delim|other constant|delim} - - The location span the content of the string, without the delimiters. - *) - | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - - type location_stack = Location.t list - - (** {1 Extension points} *) - - type attribute (*IF_CURRENT = Parsetree.attribute *) = { - attr_name : string loc; - attr_payload : payload; - attr_loc : Location.t; - } - (* [@id ARG] - [@@id ARG] - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - - and extension = string loc * payload - (* [%id ARG] - [%%id ARG] - - Sub-language placeholder -- rejected by the typechecker. - *) - - and attributes = attribute list - - and payload (*IF_CURRENT = Parsetree.payload *) = - | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - - (** {1 Core language} *) - - (* Type expressions *) - - and core_type (*IF_CURRENT = Parsetree.core_type *) = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_loc_stack: location_stack; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and core_type_desc (*IF_CURRENT = Parsetree.core_type_desc *) = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional - *) - | Ptyp_tuple of core_type list - (* T1 * ... * Tn - - Invariant: n >= 2 - *) - | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of object_field list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). - - - As the core_type of a Pctf_method node. - - - As the core_type of a Pexp_poly node. - - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - - - As the pval_type field of a value_description. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) - - and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) - - and row_field (*IF_CURRENT = Parsetree.row_field *) = { - prf_desc : row_field_desc; - prf_loc : Location.t; - prf_attributes : attributes; - } - - and row_field_desc (*IF_CURRENT = Parsetree.row_field_desc *) = - | Rtag of label loc * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 'bool' field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - *) - | Rinherit of core_type - (* [ | t ] *) - - and object_field (*IF_CURRENT = Parsetree.object_field *) = { - pof_desc : object_field_desc; - pof_loc : Location.t; - pof_attributes : attributes; - } - - and object_field_desc (*IF_CURRENT = Parsetree.object_field_desc *) = - | Otag of label loc * core_type - | Oinherit of core_type - - (* Patterns *) - - and pattern (*IF_CURRENT = Parsetree.pattern *) = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_loc_stack: location_stack; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and pattern_desc (*IF_CURRENT = Parsetree.pattern_desc *) = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Ppat_interval of constant * constant - (* 'a'..'z' - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (* (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Ppat_construct of Longident.t loc * (string loc list * pattern) option - (* C None - C P Some ([], P) - C (P1, ..., Pn) Some ([], Ppat_tuple [P1; ...; Pn]) - C (type a b) P Some ([a; b], P) - *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) - | Ppat_unpack of string option loc - (* (module P) Some "P" - (module _) None - - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of Longident.t loc * pattern - (* M.(P) *) - - (* Value expressions *) - - and expression (*IF_CURRENT = Parsetree.expression *) = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_loc_stack: location_stack; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and expression_desc (*IF_CURRENT = Parsetree.expression_desc *) = - | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) - | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_tuple of expression list - (* (E1, ..., En) - - Invariant: n >= 2 - *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) - | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) - | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * label loc - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of label loc * expression - (* x <- 2 *) - | Pexp_override of (label loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) - | Pexp_letmodule of string option loc * module_expr * expression - (* let module M = ME in E *) - | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) - | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) - | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string loc * expression - (* fun (type t) -> E *) - | Pexp_pack of module_expr - (* (module ME) - - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of open_declaration * expression - (* M.(E) - let open M in E - let! open M in E *) - | Pexp_letop of letop - (* let* P = E in E - let* P = E and* P = E in E *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable - (* . *) - - and case (*IF_CURRENT = Parsetree.case *) = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - - and letop (*IF_CURRENT = Parsetree.letop *) = - { - let_ : binding_op; - ands : binding_op list; - body : expression; - } - - and binding_op (*IF_CURRENT = Parsetree.binding_op *) = - { - pbop_op : string loc; - pbop_pat : pattern; - pbop_exp : expression; - pbop_loc : Location.t; - } - - (* Value descriptions *) - - and value_description (*IF_CURRENT = Parsetree.value_description *) = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } - -(* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) -*) - - (* Type declarations *) - - and type_declaration (*IF_CURRENT = Parsetree.type_declaration *) = - { - ptype_name: string loc; - ptype_params: (core_type * (variance * injectivity)) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } - -(* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) -*) - - and type_kind (*IF_CURRENT = Parsetree.type_kind *) = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) - | Ptype_open - - and label_declaration (*IF_CURRENT = Parsetree.label_declaration *) = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l : T [@id1] [@id2] *) - } - - (* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. - *) - - and constructor_declaration (*IF_CURRENT = Parsetree.constructor_declaration *) = - { - pcd_name: string loc; - pcd_vars: string loc list; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - and constructor_arguments (*IF_CURRENT = Parsetree.constructor_arguments *) = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - -(* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) -*) - - and type_extension (*IF_CURRENT = Parsetree.type_extension *) = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * (variance * injectivity)) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_loc: Location.t; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } -(* - type t += ... -*) - - and extension_constructor (*IF_CURRENT = Parsetree.extension_constructor *) = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - - (* exception E *) - and type_exception (*IF_CURRENT = Parsetree.type_exception *) = - { - ptyexn_constructor: extension_constructor; - ptyexn_loc: Location.t; - ptyexn_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and extension_constructor_kind (*IF_CURRENT = Parsetree.extension_constructor_kind *) = - Pext_decl of string loc list * constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([], [T1; ...; Tn], None) - | C: T0 ([], [], Some T0) - | C: T1 * ... * Tn -> T0 ([], [T1; ...; Tn], Some T0) - | C: 'a... . T1... -> T0 (['a;...]; [T1;...], Some T0) - *) - | Pext_rebind of Longident.t loc - (* - | C = D - *) - - (** {1 Class language} *) - - (* Type expressions for the class language *) - - and class_type (*IF_CURRENT = Parsetree.class_type *) = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_type_desc (*IF_CURRENT = Parsetree.class_type_desc *) = - | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) - | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - | Pcty_open of open_description * class_type - (* let open M in CT *) - - and class_signature (*IF_CURRENT = Parsetree.class_signature *) = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } - (* object('selfpat) ... end - object ... end (self = Ptyp_any) - *) - - and class_type_field (*IF_CURRENT = Parsetree.class_type_field *) = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_type_field_desc (*IF_CURRENT = Parsetree.class_type_field_desc *) = - | Pctf_inherit of class_type - (* inherit CT *) - | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) - - and 'a class_infos (*IF_CURRENT = 'a Parsetree.class_infos *) = - { - pci_virt: virtual_flag; - pci_params: (core_type * (variance * injectivity)) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - (* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... - - Also used for "class type" declaration. - *) - - and class_description = class_type class_infos - - and class_type_declaration = class_type class_infos - - (* Value expressions for the class language *) - - and class_expr (*IF_CURRENT = Parsetree.class_expr *) = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and class_expr_desc (*IF_CURRENT = Parsetree.class_expr_desc *) = - | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - | Pcl_open of open_description * class_expr - (* let open M in CE *) - - - and class_structure (*IF_CURRENT = Parsetree.class_structure *) = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } - (* object(selfpat) ... end - object ... end (self = Ppat_any) - *) - - and class_field (*IF_CURRENT = Parsetree.class_field *) = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - - and class_field_desc (*IF_CURRENT = Parsetree.class_field_desc *) = - | Pcf_inherit of override_flag * class_expr * string loc option - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) - | Pcf_val of (label loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) - | Pcf_method of (label loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) - - and class_field_kind (*IF_CURRENT = Parsetree.class_field_kind *) = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - - and class_declaration = class_expr class_infos - - (** {1 Module language} *) - - (* Type expressions for the module language *) - - and module_type (*IF_CURRENT = Parsetree.module_type *) = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_type_desc (*IF_CURRENT = Parsetree.module_type_desc *) = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) - | Pmty_functor of functor_parameter * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) - - and functor_parameter (*IF_CURRENT = Parsetree.functor_parameter *) = - | Unit - (* () *) - | Named of string option loc * module_type - (* (X : MT) Some X, MT - (_ : MT) None, MT *) - - and signature = signature_item list - - and signature_item (*IF_CURRENT = Parsetree.signature_item *) = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - - and signature_item_desc (*IF_CURRENT = Parsetree.signature_item_desc *) = - | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) - | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typesubst of type_declaration list - (* type t1 := ... and ... and tn := ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of type_exception - (* exception C of T *) - | Psig_module of module_declaration - (* module X = M - module X : MT *) - | Psig_modsubst of module_substitution - (* module X := M *) - | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) - | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_modtypesubst of module_type_declaration - (* module type S := ... *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of class_description list - (* class c1 : ... and ... and cn : ... *) - | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) - - and module_declaration (*IF_CURRENT = Parsetree.module_declaration *) = - { - pmd_name: string option loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } - (* S : MT *) - - and module_substitution (*IF_CURRENT = Parsetree.module_substitution *) = - { - pms_name: string loc; - pms_manifest: Longident.t loc; - pms_attributes: attributes; (* ... [@@id1] [@@id2] *) - pms_loc: Location.t; - } - - and module_type_declaration (*IF_CURRENT = Parsetree.module_type_declaration *) = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } - (* S = MT - S (abstract module type declaration, pmtd_type = None) - *) - - and 'a open_infos (*IF_CURRENT = 'a Parsetree.open_infos *) = - { - popen_expr: 'a; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } - (* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) - - and open_description = Longident.t loc open_infos - (* open M.N - open M(N).O *) - - and open_declaration = module_expr open_infos - (* open M.N - open M(N).O - open struct ... end *) - - and 'a include_infos (*IF_CURRENT = 'a Parsetree.include_infos *) = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - - and include_description = module_type include_infos - (* include MT *) - - and include_declaration = module_expr include_infos - (* include ME *) - - and with_constraint (*IF_CURRENT = Parsetree.with_constraint *) = - | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) - | Pwith_modtype of Longident.t loc * module_type - (* with module type X.Y = Z *) - | Pwith_modtypesubst of Longident.t loc * module_type - (* with module type X.Y := sig end *) - | Pwith_typesubst of Longident.t loc * type_declaration - (* with type X.t := ..., same format as [Pwith_type] *) - | Pwith_modsubst of Longident.t loc * Longident.t loc - (* with module X.Y := Z *) - - (* Value expressions for the module language *) - - and module_expr (*IF_CURRENT = Parsetree.module_expr *) = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } - - and module_expr_desc (*IF_CURRENT = Parsetree.module_expr_desc *) = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) - | Pmod_functor of functor_parameter * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) - - and structure = structure_item list - - and structure_item (*IF_CURRENT = Parsetree.structure_item *) = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - - and structure_item_desc (*IF_CURRENT = Parsetree.structure_item_desc *) = - | Pstr_eval of expression * attributes - (* E *) - | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) - | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) - | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) - | Pstr_exception of type_exception - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) - | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_declaration - (* open X *) - | Pstr_class of class_declaration list - (* class c1 = ... and ... and cn = ... *) - | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) - - and value_binding (*IF_CURRENT = Parsetree.value_binding *) = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - - and module_binding (*IF_CURRENT = Parsetree.module_binding *) = - { - pmb_name: string option loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } - (* X = ME *) - - (** {1 Toplevel} *) - - (* Toplevel phrases *) - - type toplevel_phrase (*IF_CURRENT = Parsetree.toplevel_phrase *) = - | Ptop_def of structure - | Ptop_dir of toplevel_directive - (* #use, #load ... *) - - and toplevel_directive (*IF_CURRENT = Parsetree.toplevel_directive *) = - { - pdir_name : string loc; - pdir_arg : directive_argument option; - pdir_loc : Location.t; - } - - and directive_argument (*IF_CURRENT = Parsetree.directive_argument *) = - { - pdira_desc : directive_argument_desc; - pdira_loc : Location.t; - } - - and directive_argument_desc (*IF_CURRENT = Parsetree.directive_argument_desc *) = - | Pdir_string of string - | Pdir_int of string * char option - | Pdir_ident of Longident.t - | Pdir_bool of bool -end - -module Docstrings: sig - (** Documentation comments - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - - *) - - (** (Re)Initialise all docstring state *) - val init : unit -> unit - - (** Emit warnings for unattached and ambiguous docstrings *) - val warn_bad_docstrings : unit -> unit - - (** {2 Docstrings} *) - - (** Documentation comments *) - type docstring - - (** Create a docstring *) - val docstring : string -> Location.t -> docstring - - (** Register a docstring *) - val register : docstring -> unit - - (** Get the text of a docstring *) - val docstring_body : docstring -> string - - (** Get the location of a docstring *) - val docstring_loc : docstring -> Location.t - - (** {2 Set functions} - - These functions are used by the lexer to associate docstrings to - the locations of tokens. *) - - (** Docstrings immediately preceding a token *) - val set_pre_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately following a token *) - val set_post_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings not immediately adjacent to a token *) - val set_floating_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately following the token which precedes this one *) - val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit - - (** Docstrings immediately preceding the token which follows this one *) - val set_post_extra_docstrings : Lexing.position -> docstring list -> unit - - (** {2 Items} - - The {!docs} type represents documentation attached to an item. *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - val empty_docs : docs - - val docs_attr : docstring -> Parsetree.attribute - - (** Convert item documentation to attributes and add them to an - attribute list *) - val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) - val symbol_docs : unit -> docs - val symbol_docs_lazy : unit -> docs Lazy.t - - (** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) - val rhs_docs : int -> int -> docs - val rhs_docs_lazy : int -> int -> docs Lazy.t - - (** Mark the item documentation for the current symbol (for ambiguity - warnings). *) - val mark_symbol_docs : unit -> unit - - (** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) - val mark_rhs_docs : int -> int -> unit - - (** {2 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - - type info = docstring option - - val empty_info : info - - val info_attr : docstring -> Parsetree.attribute - - (** Convert field info to attributes and add them to an - attribute list *) - val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the field info for the current symbol. *) - val symbol_info : unit -> info - - (** Fetch the field info following the symbol at a given position. *) - val rhs_info : int -> info - - (** {2 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - - type text = docstring list - - val empty_text : text - val empty_text_lazy : text Lazy.t - - val text_attr : docstring -> Parsetree.attribute - - (** Convert text to attributes and add them to an attribute list *) - val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - - (** Fetch the text preceding the current symbol. *) - val symbol_text : unit -> text - val symbol_text_lazy : unit -> text Lazy.t - - (** Fetch the text preceding the symbol at the given position. *) - val rhs_text : int -> text - val rhs_text_lazy : int -> text Lazy.t - - (** {2 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - - (** Fetch additional text preceding the current symbol *) - val symbol_pre_extra_text : unit -> text - - (** Fetch additional text following the current symbol *) - val symbol_post_extra_text : unit -> text - - (** Fetch additional text preceding the symbol at the given position *) - val rhs_pre_extra_text : int -> text - - (** Fetch additional text following the symbol at the given position *) - val rhs_post_extra_text : int -> text - - (** Fetch text following the symbol at the given position *) - val rhs_post_text : int -> text - - module WithMenhir: sig - (** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) - val symbol_docs : Lexing.position * Lexing.position -> docs - val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t - - (** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) - val rhs_docs : Lexing.position -> Lexing.position -> docs - val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t - - (** Mark the item documentation for the current symbol (for ambiguity - warnings). *) - val mark_symbol_docs : Lexing.position * Lexing.position -> unit - - (** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) - val mark_rhs_docs : Lexing.position -> Lexing.position -> unit - - (** Fetch the field info for the current symbol. *) - val symbol_info : Lexing.position -> info - - (** Fetch the field info following the symbol at a given position. *) - val rhs_info : Lexing.position -> info - - (** Fetch the text preceding the current symbol. *) - val symbol_text : Lexing.position -> text - val symbol_text_lazy : Lexing.position -> text Lazy.t - - (** Fetch the text preceding the symbol at the given position. *) - val rhs_text : Lexing.position -> text - val rhs_text_lazy : Lexing.position -> text Lazy.t - - (** {3 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - - (** Fetch additional text preceding the current symbol *) - val symbol_pre_extra_text : Lexing.position -> text - - (** Fetch additional text following the current symbol *) - val symbol_post_extra_text : Lexing.position -> text - - (** Fetch additional text preceding the symbol at the given position *) - val rhs_pre_extra_text : Lexing.position -> text - - (** Fetch additional text following the symbol at the given position *) - val rhs_post_extra_text : Lexing.position -> text - - (** Fetch text following the symbol at the given position *) - val rhs_post_text : Lexing.position -> text - - end -end = struct - open Location - - (* Docstrings *) - - (* A docstring is "attached" if it has been inserted in the AST. This - is used for generating unexpected docstring warnings. *) - type ds_attached = - | Unattached (* Not yet attached anything.*) - | Info (* Attached to a field or constructor. *) - | Docs (* Attached to an item or as floating text. *) - - (* A docstring is "associated" with an item if there are no blank lines between - them. This is used for generating docstring ambiguity warnings. *) - type ds_associated = - | Zero (* Not associated with an item *) - | One (* Associated with one item *) - | Many (* Associated with multiple items (ambiguity) *) - - type docstring = - { ds_body: string; - ds_loc: Location.t; - mutable ds_attached: ds_attached; - mutable ds_associated: ds_associated; } - - (* List of docstrings *) - - let docstrings : docstring list ref = ref [] - - (* Warn for unused and ambiguous docstrings *) - - let warn_bad_docstrings () = - if Warnings.is_active (Migrate_parsetree_compiler_functions.bad_docstring true) then begin - List.iter - (fun ds -> - match ds.ds_attached with - | Info -> () - | Unattached -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring true) - | Docs -> - match ds.ds_associated with - | Zero | One -> () - | Many -> - prerr_warning ds.ds_loc (Migrate_parsetree_compiler_functions.bad_docstring true)) - (List.rev !docstrings) - end - - (* Docstring constructors and destructors *) - - let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; - ds_attached = Unattached; - ds_associated = Zero; } - in - ds - - let register ds = - docstrings := ds :: !docstrings - - let docstring_body ds = ds.ds_body - - let docstring_loc ds = ds.ds_loc - - (* Docstrings attached to items *) - - type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - - let empty_docs = { docs_pre = None; docs_post = None } - - let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - - let docs_attr ds = - let open Parsetree in - let body = ds.ds_body in - let loc = ds.ds_loc in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } - in - { attr_name = doc_loc; - attr_payload = PStr [item]; - attr_loc = loc } - - let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - - (* Docstrings attached to constructors or fields *) - - type info = docstring option - - let empty_info = None - - let info_attr = docs_attr - - let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - - (* Docstrings not attached to a specific item *) - - type text = docstring list - - let empty_text = [] - let empty_text_lazy = lazy [] - - let text_loc = {txt = "ocaml.text"; loc = Location.none} - - let text_attr ds = - let open Parsetree in - let body = ds.ds_body in - let loc = ds.ds_loc in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(body, loc, None)); - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = loc } - in - { attr_name = text_loc; - attr_payload = PStr [item]; - attr_loc = loc } - - let add_text_attrs dsl attrs = - let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in - (List.map text_attr fdsl) @ attrs - - (* Find the first non-info docstring in a list, attach it and return it *) - let get_docstring ~info dsl = - let rec loop = function - | [] -> None - | {ds_attached = Info; _} :: rest -> loop rest - | ds :: _ -> - ds.ds_attached <- if info then Info else Docs; - Some ds - in - loop dsl - - (* Find all the non-info docstrings in a list, attach them and return them *) - let get_docstrings dsl = - let rec loop acc = function - | [] -> List.rev acc - | {ds_attached = Info; _} :: rest -> loop acc rest - | ds :: rest -> - ds.ds_attached <- Docs; - loop (ds :: acc) rest - in - loop [] dsl - - (* "Associate" all the docstrings in a list *) - let associate_docstrings dsl = - List.iter - (fun ds -> - match ds.ds_associated with - | Zero -> ds.ds_associated <- One - | (One | Many) -> ds.ds_associated <- Many) - dsl - - (* Map from positions to pre docstrings *) - - let pre_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_pre_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_table pos dsl - - let get_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - - let mark_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl - with Not_found -> () - - (* Map from positions to post docstrings *) - - let post_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_post_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_table pos dsl - - let get_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - - let mark_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl - with Not_found -> () - - let get_info pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstring ~info:true dsl - with Not_found -> None - - (* Map from positions to floating docstrings *) - - let floating_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_floating_docstrings pos dsl = - if dsl <> [] then Hashtbl.add floating_table pos dsl - - let get_text pos = - try - let dsl = Hashtbl.find floating_table pos in - get_docstrings dsl - with Not_found -> [] - - let get_post_text pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstrings dsl - with Not_found -> [] - - (* Maps from positions to extra docstrings *) - - let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_pre_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_extra_table pos dsl - - let get_pre_extra_text pos = - try - let dsl = Hashtbl.find pre_extra_table pos in - get_docstrings dsl - with Not_found -> [] - - let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - - let set_post_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_extra_table pos dsl - - let get_post_extra_text pos = - try - let dsl = Hashtbl.find post_extra_table pos in - get_docstrings dsl - with Not_found -> [] - - (* Docstrings from parser actions *) - module WithParsing = struct - let symbol_docs () = - { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); - docs_post = get_post_docs (Parsing.symbol_end_pos ()); } - - let symbol_docs_lazy () = - let p1 = Parsing.symbol_start_pos () in - let p2 = Parsing.symbol_end_pos () in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); - docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } - - let rhs_docs_lazy pos1 pos2 = - let p1 = Parsing.rhs_start_pos pos1 in - let p2 = Parsing.rhs_end_pos pos2 in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let mark_symbol_docs () = - mark_pre_docs (Parsing.symbol_start_pos ()); - mark_post_docs (Parsing.symbol_end_pos ()) - - let mark_rhs_docs pos1 pos2 = - mark_pre_docs (Parsing.rhs_start_pos pos1); - mark_post_docs (Parsing.rhs_end_pos pos2) - - let symbol_info () = - get_info (Parsing.symbol_end_pos ()) - - let rhs_info pos = - get_info (Parsing.rhs_end_pos pos) - - let symbol_text () = - get_text (Parsing.symbol_start_pos ()) - - let symbol_text_lazy () = - let pos = Parsing.symbol_start_pos () in - lazy (get_text pos) - - let rhs_text pos = - get_text (Parsing.rhs_start_pos pos) - - let rhs_post_text pos = - get_post_text (Parsing.rhs_end_pos pos) - - let rhs_text_lazy pos = - let pos = Parsing.rhs_start_pos pos in - lazy (get_text pos) - - let symbol_pre_extra_text () = - get_pre_extra_text (Parsing.symbol_start_pos ()) - - let symbol_post_extra_text () = - get_post_extra_text (Parsing.symbol_end_pos ()) - - let rhs_pre_extra_text pos = - get_pre_extra_text (Parsing.rhs_start_pos pos) - - let rhs_post_extra_text pos = - get_post_extra_text (Parsing.rhs_end_pos pos) - end - - include WithParsing - - module WithMenhir = struct - let symbol_docs (startpos, endpos) = - { docs_pre = get_pre_docs startpos; - docs_post = get_post_docs endpos; } - - let symbol_docs_lazy (p1, p2) = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs pos1; - docs_post = get_post_docs pos2; } - - let rhs_docs_lazy p1 p2 = - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - - let mark_symbol_docs (startpos, endpos) = - mark_pre_docs startpos; - mark_post_docs endpos; - () - - let mark_rhs_docs pos1 pos2 = - mark_pre_docs pos1; - mark_post_docs pos2; - () - - let symbol_info endpos = - get_info endpos - - let rhs_info endpos = - get_info endpos - - let symbol_text startpos = - get_text startpos - - let symbol_text_lazy startpos = - lazy (get_text startpos) - - let rhs_text pos = - get_text pos - - let rhs_post_text pos = - get_post_text pos - - let rhs_text_lazy pos = - lazy (get_text pos) - - let symbol_pre_extra_text startpos = - get_pre_extra_text startpos - - let symbol_post_extra_text endpos = - get_post_extra_text endpos - - let rhs_pre_extra_text pos = - get_pre_extra_text pos - - let rhs_post_extra_text pos = - get_post_extra_text pos - end - - (* (Re)Initialise all comment state *) - - let init () = - docstrings := []; - Hashtbl.reset pre_table; - Hashtbl.reset post_table; - Hashtbl.reset floating_table; - Hashtbl.reset pre_extra_table; - Hashtbl.reset post_extra_table -end -module Ast_helper: sig - (** Helpers to produce Parsetree fragments - - {b Warning} This module is unstable and part of - {{!Compiler_libs}compiler-libs}. - - *) - - open Asttypes - open Docstrings - open Parsetree - - type 'a with_loc = 'a Location.loc - type loc = Location.t - - type lid = Longident.t with_loc - type str = string with_loc - type str_opt = string option with_loc - type attrs = attribute list - - (** {1 Default locations} *) - - val default_loc: loc ref - (** Default value for all optional location arguments. *) - - val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - - (** {1 Constants} *) - - module Const : sig - val char : char -> constant - val string : - ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant - end - - (** {1 Attributes} *) - module Attr : sig - val mk: ?loc:loc -> str -> payload -> attribute - end - - (** {1 Core language} *) - - (** Type expressions *) - module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - - (** Patterns *) - module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> - lid -> (str list * pattern) option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - - (** Expressions *) - module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr - -> expression -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression - -> expression - val letop: ?loc:loc -> ?attrs:attrs -> binding_op - -> binding_op list -> expression -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - val binding_op: str -> pattern -> expression -> loc -> binding_op - end - - (** Value declarations *) - module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - - (** Type declarations *) - module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * (variance * injectivity)) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> - str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - - (** Type extensions *) - module Te: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * (variance * injectivity)) list -> - ?priv:private_flag -> lid -> extension_constructor list -> type_extension - - val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - extension_constructor -> type_exception - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> - str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - - (** {1 Module language} *) - - (** Module type expressions *) - module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - - (** Module expressions *) - module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - - (** Signature items *) - module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_subst: ?loc:loc -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> type_exception -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val mod_subst: ?loc:loc -> module_substitution -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val modtype_subst: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - - (** Structure items *) - module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> type_exception -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_declaration -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - - (** Module declarations *) - module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_type -> module_declaration - end - - (** Module substitutions *) - module Ms: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> lid -> module_substitution - end - - (** Module type declarations *) - module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - - (** Module bindings *) - module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_expr -> module_binding - end - - (** Opens *) - module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> 'a -> 'a open_infos - end - - (** Includes *) - module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - - (** Value bindings *) - module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - - (** {1 Class language} *) - - (** Class type expressions *) - module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type - -> class_type - end - - (** Class type fields *) - module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - - (** Class expressions *) - module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr - -> class_expr - end - - (** Class fields *) - module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - - (** Classes *) - module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> - ?params:(core_type * (variance * injectivity)) list -> - str -> 'a -> 'a class_infos - end - - (** Class signatures *) - module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - - (** Class structures *) - module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - - (** Row fields *) - module Rf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> bool -> core_type list -> row_field - val inherit_: ?loc:loc -> core_type -> row_field - end - - (** Object fields *) - module Of: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - object_field_desc -> object_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> core_type -> object_field - val inherit_: ?loc:loc -> core_type -> object_field - end -end = struct - (** Helpers to produce Parsetree fragments *) - - open Asttypes - open Parsetree - open Docstrings - - type 'a with_loc = 'a Location.loc - type loc = Location.t - - type lid = Longident.t with_loc - type str = string with_loc - type str_opt = string option with_loc - type attrs = attribute list - - let default_loc = ref Location.none - - let with_default_loc l f = - Misc.protect_refs [Misc.R (default_loc, l)] f - - module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (string_of_int i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char c - let string ?quotation_delimiter ?(loc= !default_loc) s = - Pconst_string (s, loc, quotation_delimiter) - end - - module Attr = struct - let mk ?(loc= !default_loc) name payload = - { attr_name = name; - attr_payload = payload; - attr_loc = loc } - end - - module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; - ptyp_loc = loc; - ptyp_loc_stack = []; - ptyp_attributes = attrs} - - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - - let varify_constructors var_names t = - let check_variable vl loc v = - if List.mem v vl then - raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in - let var_names = List.map (fun v -> v.txt) var_names in - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> - check_variable var_names t.ptyp_loc x; - Ptyp_var x - | Ptyp_arrow (label,core_type,core_type') -> - Ptyp_arrow(label, loop core_type, loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr( { txt = Longident.Lident s }, []) - when List.mem s var_names -> - Ptyp_var s - | Ptyp_constr(longident, lst) -> - Ptyp_constr(longident, List.map loop lst) - | Ptyp_object (lst, o) -> - Ptyp_object (List.map loop_object_field lst, o) - | Ptyp_class (longident, lst) -> - Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) - in - {t with ptyp_desc = desc} - and loop_row_field field = - let prf_desc = match field.prf_desc with - | Rtag(label,flag,lst) -> - Rtag(label,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - in - { field with prf_desc; } - and loop_object_field field = - let pof_desc = match field.pof_desc with - | Otag(label, t) -> - Otag(label, loop t) - | Oinherit t -> - Oinherit (loop t) - in - { field with pof_desc; } - in - loop t - - end - - module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; - ppat_loc = loc; - ppat_loc_stack = []; - ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) - end - - module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; - pexp_loc = loc; - pexp_loc_stack = []; - pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_open (a, b)) - let letop ?loc ?attrs let_ ands body = - mk ?loc ?attrs (Pexp_letop {let_; ands; body}) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } - - let binding_op op pat exp loc = - { - pbop_op = op; - pbop_pat = pat; - pbop_exp = exp; - pbop_loc = loc; - } - end - - module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_functor (a, b)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) - end - - module Mod = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg body = - mk ?loc ?attrs (Pmod_functor (arg, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) - end - - module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_subst ?loc a = mk ?loc (Psig_typesubst a) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let mod_subst ?loc a = mk ?loc (Psig_modsubst a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let modtype_subst ?loc a = mk ?loc (Psig_modtypesubst a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - let class_ ?loc a = mk ?loc (Psig_class a) - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_ ?loc a = mk ?loc (Pstr_class a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - end - - module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_open (a, b)) - end - - module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Pcty_open (a, b)) - end - - module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - - end - - module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_inherit (a, b, c)) - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = List.filter (fun ds -> docstring_body ds <> "") txt in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - - end - - module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } - end - - module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } - end - - module Ms = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name syn = - { - pms_name = name; - pms_manifest = syn; - pms_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pms_loc = loc; - } - end - - module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } - end - - module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } - end - - module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) expr = - { - popen_expr = expr; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } - end - - module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - - end - - module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } - end - - module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } - end - - module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(vars = []) ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_vars = vars; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - - end - - (** Type extensions *) - module Te = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_loc = loc; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let mk_exception ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - constructor = - { - ptyexn_constructor = constructor; - ptyexn_loc = loc; - ptyexn_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(vars = []) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(vars, args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - end - - module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } - end - - module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } - end - - (** Row fields *) - module Rf = struct - let mk ?(loc = !default_loc) ?(attrs = []) desc = { - prf_desc = desc; - prf_loc = loc; - prf_attributes = attrs; - } - let tag ?loc ?attrs label const tys = - mk ?loc ?attrs (Rtag (label, const, tys)) - let inherit_?loc ty = - mk ?loc (Rinherit ty) - end - - (** Object fields *) - module Of = struct - let mk ?(loc = !default_loc) ?(attrs=[]) desc = { - pof_desc = desc; - pof_loc = loc; - pof_attributes = attrs; - } - let tag ?loc ?attrs label ty = - mk ?loc ?attrs (Otag (label, ty)) - let inherit_ ?loc ty = - mk ?loc (Oinherit ty) - end -end -module Ast_mapper: sig - (** The interface of a -ppx rewriter - - A -ppx rewriter is a program that accepts a serialized abstract syntax - tree and outputs another, possibly modified, abstract syntax tree. - This module encapsulates the interface between the compiler and - the -ppx rewriters, handling such details as the serialization format, - forwarding of command-line flags, and storing state. - - {!mapper} enables AST rewriting using open recursion. - A typical mapper would be based on {!default_mapper}, a deep - identity mapper, and will fall back on it for handling the syntax it - does not modify. For example: - - {[ - open Asttypes - open Parsetree - open Ast_mapper - - let test_mapper argv = - { default_mapper with - expr = fun mapper expr -> - match expr with - | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> - Ast_helper.Exp.constant (Const_int 42) - | other -> default_mapper.expr mapper other; } - - let () = - register "ppx_test" test_mapper]} - - This -ppx rewriter, which replaces [[%test]] in expressions with - the constant [42], can be compiled using - [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - - *) - - open Parsetree - - (** {1 A generic Parsetree mapper} *) - - type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - (** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - - val default_mapper: mapper - (** A default mapper, which implements a "deep identity" mapping. *) - - (** {1 Apply mappers to compilation units} *) - - val tool_name: unit -> string - (** Can be used within a ppx preprocessor to know which tool is - calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], - ["ocaml"], ... Some global variables that reflect command-line - options are automatically synchronized between the calling tool - and the ppx preprocessor: {!Clflags.include_dirs}, - {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package}, - {!Clflags.debug}. *) - - - val apply: source:string -> target:string -> mapper -> unit - (** Apply a mapper (parametrized by the unit name) to a dumped - parsetree found in the [source] file and put the result in the - [target] file. The [structure] or [signature] field of the mapper - is applied to the implementation or interface. *) - - val run_main: (string list -> mapper) -> unit - (** Entry point to call to implement a standalone -ppx rewriter from a - mapper, parametrized by the command line arguments. The current - unit name can be obtained from {!Location.input_name}. This - function implements proper error reporting for uncaught - exceptions. *) - - (** {1 Registration API} *) - - val register_function: (string -> (string list -> mapper) -> unit) ref - - val register: string -> (string list -> mapper) -> unit - (** Apply the [register_function]. The default behavior is to run the - mapper immediately, taking arguments from the process command - line. This is to support a scenario where a mapper is linked as a - stand-alone executable. - - It is possible to overwrite the [register_function] to define - "-ppx drivers", which combine several mappers in a single process. - Typically, a driver starts by defining [register_function] to a - custom implementation, then lets ppx rewriters (linked statically - or dynamically) register themselves, and then run all or some of - them. It is also possible to have -ppx drivers apply rewriters to - only specific parts of an AST. - - The first argument to [register] is a symbolic name to be used by - the ppx driver. *) - - - (** {1 Convenience functions to write mappers} *) - - val map_opt: ('a -> 'b) -> 'a option -> 'b option - - val extension_of_error: Location.error -> extension - (** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) - - val attribute_of_warning: Location.t -> string -> attribute - (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) - - (** {1 Helper functions to call external mappers} *) - - val add_ppx_context_str: - tool_name:string -> Parsetree.structure -> Parsetree.structure - (** Extract information from the current environment and encode it - into an attribute which is prepended to the list of structure - items in order to pass the information to an external - processor. *) +module Asttypes = struct + type constant (*IF_CURRENT = Asttypes.constant *) = + Const_int of int + | Const_char of char + | Const_string of string * Location.t * string option + | Const_float of string + | Const_int32 of int32 + | Const_int64 of int64 + | Const_nativeint of nativeint - val add_ppx_context_sig: - tool_name:string -> Parsetree.signature -> Parsetree.signature - (** Same as [add_ppx_context_str], but for signatures. *) + type rec_flag (*IF_CURRENT = Asttypes.rec_flag *) = Nonrecursive | Recursive - val drop_ppx_context_str: - restore:bool -> Parsetree.structure -> Parsetree.structure - (** Drop the ocaml.ppx.context attribute from a structure. If - [restore] is true, also restore the associated data in the current - process. *) + type direction_flag (*IF_CURRENT = Asttypes.direction_flag *) = Upto | Downto - val drop_ppx_context_sig: - restore:bool -> Parsetree.signature -> Parsetree.signature - (** Same as [drop_ppx_context_str], but for signatures. *) + (* Order matters, used in polymorphic comparison *) + type private_flag (*IF_CURRENT = Asttypes.private_flag *) = Private | Public - (** {1 Cookies} *) + type mutable_flag (*IF_CURRENT = Asttypes.mutable_flag *) = Immutable | Mutable - (** Cookies are used to pass information from a ppx processor to - a further invocation of itself, when called from the OCaml - toplevel (or other tools that support cookies). *) + type virtual_flag (*IF_CURRENT = Asttypes.virtual_flag *) = Virtual | Concrete - val set_cookie: string -> Parsetree.expression -> unit - val get_cookie: string -> Parsetree.expression option - end = struct - (* A generic Parsetree mapping class *) + type override_flag (*IF_CURRENT = Asttypes.override_flag *) = Override | Fresh - (* - [@@@ocaml.warning "+9"] - (* Ensure that record patterns don't miss any field. *) - *) + type closed_flag (*IF_CURRENT = Asttypes.closed_flag *) = Closed | Open - open Parsetree - open Ast_helper - open Location + type label = string - module String = Misc.Stdlib.String + type arg_label (*IF_CURRENT = Asttypes.arg_label *) = + Nolabel + | Labelled of string (* label:T -> ... *) + | Optional of string (* ?label:T -> ... *) - type mapper (*IF_CURRENT = Ast_mapper.mapper *) = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; + type 'a loc = 'a Location.loc = { + txt : 'a; + loc : Location.t; } - let map_fst f (x, y) = (f x, y) - let map_snd f (x, y) = (x, f y) - let map_tuple f1 f2 (x, y) = (f1 x, f2 y) - let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) - let map_opt f = function None -> None | Some x -> Some (f x) - - let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - - module C = struct - (* Constants *) - - let map sub c = match c with - | Pconst_integer _ - | Pconst_char _ - | Pconst_float _ - -> c - | Pconst_string (s, loc, quotation_delimiter) -> - let loc = sub.location sub loc in - Const.string ~loc ?quotation_delimiter s - end - - module T = struct - (* Type expressions for the core language *) - - let row_field sub { - prf_desc; - prf_loc; - prf_attributes; - } = - let loc = sub.location sub prf_loc in - let attrs = sub.attributes sub prf_attributes in - let desc = match prf_desc with - | Rtag (l, b, tl) -> Rtag (map_loc sub l, b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - in - Rf.mk ~loc ~attrs desc - - let object_field sub { - pof_desc; - pof_loc; - pof_attributes; - } = - let loc = sub.location sub pof_loc in - let attrs = sub.attributes sub pof_attributes in - let desc = match pof_desc with - | Otag (l, t) -> Otag (map_loc sub l, sub.typ sub t) - | Oinherit t -> Oinherit (sub.typ sub t) - in - Of.mk ~loc ~attrs desc - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs - (List.map (map_loc sub) sl) (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - let loc = sub.location sub ptype_loc in - let attrs = sub.attributes sub ptype_attributes in - Type.mk ~loc ~attrs (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_loc; - ptyext_attributes} = - let loc = sub.location sub ptyext_loc in - let attrs = sub.attributes sub ptyext_attributes in - Te.mk ~loc ~attrs - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - - let map_type_exception sub - {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = - let loc = sub.location sub ptyexn_loc in - let attrs = sub.attributes sub ptyexn_attributes in - Te.mk_exception ~loc ~attrs - (sub.extension_constructor sub ptyexn_constructor) - - let map_extension_constructor_kind sub = function - Pext_decl(vars, ctl, cto) -> - Pext_decl(List.map (map_loc sub) vars, - map_constructor_arguments sub ctl, - map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - let loc = sub.location sub pext_loc in - let attrs = sub.attributes sub pext_attributes in - Te.constructor ~loc ~attrs - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - - end - - module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (o, ct) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_type sub ct) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) - end - - let map_functor_param sub = function - | Unit -> Unit - | Named (s, mt) -> Named (map_loc sub s, sub.module_type sub mt) - - module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (param, mt) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_type sub mt) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_modtype (lid, mty) -> - Pwith_modtype (map_loc sub lid, sub.module_type sub mty) - | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - | Pwith_modtypesubst (lid, mty) -> - Pwith_modtypesubst (map_loc sub lid, sub.module_type sub mty) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> - type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typesubst l -> - type_subst ~loc (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_modsubst x -> mod_subst ~loc (sub.module_substitution sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_modtypesubst x -> - modtype_subst ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) - end - - - module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (param, body) -> - functor_ ~loc ~attrs - (map_functor_param sub param) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - let attrs = sub.attributes sub attrs in - eval ~loc ~attrs (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.type_exception sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_declaration sub x) - | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - let attrs = sub.attributes sub attrs in - extension ~loc ~attrs (sub.extension sub x) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) - end - - module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs (sub.constant sub x) - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> - send ~loc ~attrs (sub.expr sub e) (map_loc sub s) - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (o, e) -> - open_ ~loc ~attrs (sub.open_declaration sub o) (sub.expr sub e) - | Pexp_letop {let_; ands; body} -> - letop ~loc ~attrs (sub.binding_op sub let_) - (List.map (sub.binding_op sub) ands) (sub.expr sub body) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () - - let map_binding_op sub {pbop_op; pbop_pat; pbop_exp; pbop_loc} = - let open Exp in - let op = map_loc sub pbop_op in - let pat = sub.pat sub pbop_pat in - let exp = sub.expr sub pbop_exp in - let loc = sub.location sub pbop_loc in - binding_op op pat exp loc - - end - - module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs (sub.constant sub c) - | Ppat_interval (c1, c2) -> - interval ~loc ~attrs (sub.constant sub c1) (sub.constant sub c2) - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) - (map_opt - (fun (vl, p) -> List.map (map_loc sub) vl, sub.pat sub p) - p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) - end - - module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (o, ce) -> - open_ ~loc ~attrs (sub.open_description sub o) (sub.class_expr sub ce) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit (o, ce, s) -> - inherit_ ~loc ~attrs o (sub.class_expr sub ce) - (map_opt (map_loc sub) s) - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - let loc = sub.location sub pci_loc in - let attrs = sub.attributes sub pci_attributes in - Ci.mk ~loc ~attrs - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) - end - - (* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - - let default_mapper = - { - constant = C.map; - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_declaration = - (fun this -> CE.class_infos this (this.class_expr this)); - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - class_description = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - type_exception = T.map_type_exception; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - binding_op = E.map_binding_op; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_substitution = - (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> - Ms.mk - (map_loc this pms_name) - (map_loc this pms_manifest) - ~attrs:(this.attributes this pms_attributes) - ~loc:(this.location this pms_loc) - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_declaration = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (this.module_expr this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - open_description = - (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_expr) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_vars; pcd_args; - pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~vars:(List.map (map_loc this) pcd_vars) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this a -> - { - attr_name = map_loc this a.attr_name; - attr_payload = this.payload this a.attr_payload; - attr_loc = this.location this a.attr_loc - } - ); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - - let extension_of_error error = - Locations.extension_of_error - ~mk_pstr:(fun x -> PStr x) - ~mk_extension:(fun x -> Str.extension x) - ~mk_string_constant:(fun x -> Str.eval (Exp.constant (Pconst_string (x, Location.none (* XXX *), None)))) - error - - let attribute_of_warning loc s = - Attr.mk - {loc; txt = "ocaml.ppwarning" } - (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, loc, None)))])) - - let cookies = ref String.Map.empty - - let get_cookie k = - try Some (String.Map.find k !cookies) - with Not_found -> None - - let set_cookie k v = - cookies := String.Map.add k v !cookies - - let tool_name_ref = ref "_none_" - - let tool_name () = !tool_name_ref - - - module PpxContext = struct - open Longident - open Asttypes - open Ast_helper - - let lid name = { txt = Lident name; loc = Location.none } - - let make_string s = Exp.constant (Const.string s) - - let make_bool x = - if x - then Exp.construct (lid "true") None - else Exp.construct (lid "false") None - - let rec make_list f lst = - match lst with - | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) - | [] -> - Exp.construct (lid "[]") None - - let make_pair f1 f2 (x1, x2) = - Exp.tuple [f1 x1; f2 x2] - - let make_option f opt = - match opt with - | Some x -> Exp.construct (lid "Some") (Some (f x)) - | None -> Exp.construct (lid "None") None - - let get_cookies () = - lid "cookies", - make_list (make_pair make_string (fun x -> x)) - (String.Map.bindings !cookies) - - let mk fields = - { - attr_name = { txt = "ocaml.ppx.context"; loc = Location.none }; - attr_payload = Parsetree.PStr [Str.eval (Exp.record fields None)]; - attr_loc = Location.none - } - - let make ~tool_name () = - let fields = - [ - lid "tool_name", make_string tool_name; - lid "include_dirs", make_list make_string !Clflags.include_dirs; - lid "load_path", make_list make_string (Migrate_parsetree_compiler_functions.get_load_paths ()); - lid "open_modules", make_list make_string !Clflags.open_modules; - lid "for_package", make_option make_string !Clflags.for_package; - lid "debug", make_bool !Clflags.debug; - lid "use_threads", make_bool !Clflags.use_threads; - lid "use_vmthreads", make_bool false; - lid "recursive_types", make_bool !Clflags.recursive_types; - lid "principal", make_bool !Clflags.principal; - lid "transparent_modules", make_bool !Clflags.transparent_modules; - lid "unboxed_types", make_bool (Migrate_parsetree_compiler_functions.get_unboxed_types ()); - get_cookies () - ] - in - mk fields - - let get_fields = function - | PStr [{pstr_desc = Pstr_eval - ({ pexp_desc = Pexp_record (fields, None) }, [])}] -> - fields - | _ -> - raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" - - let restore fields = - let field name payload = - let rec get_string = function - | { pexp_desc = Pexp_constant (Pconst_string (str, _, None)) } -> str - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] string syntax" name - and get_bool pexp = - match pexp with - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, - None)} -> - true - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, - None)} -> - false - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] bool syntax" name - and get_list elem = function - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> - elem exp :: get_list elem rest - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> - [] - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] list syntax" name - and get_pair f1 f2 = function - | {pexp_desc = Pexp_tuple [e1; e2]} -> - (f1 e1, f2 e2) - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] pair syntax" name - and get_option elem = function - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "Some" }, Some exp) } -> - Some (elem exp) - | { pexp_desc = - Pexp_construct ({ txt = Longident.Lident "None" }, None) } -> - None - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] option syntax" name - in - match name with - | "tool_name" -> - tool_name_ref := get_string payload - | "include_dirs" -> - Clflags.include_dirs := get_list get_string payload - | "load_path" -> - Migrate_parsetree_compiler_functions.load_path_init (get_list get_string payload) - | "open_modules" -> - Clflags.open_modules := get_list get_string payload - | "for_package" -> - Clflags.for_package := get_option get_string payload - | "debug" -> - Clflags.debug := get_bool payload - | "use_threads" -> - Clflags.use_threads := get_bool payload - | "use_vmthreads" -> - if get_bool payload then - raise_errorf "Internal error: vmthreads not supported after 4.09.0" - | "recursive_types" -> - Clflags.recursive_types := get_bool payload - | "principal" -> - Clflags.principal := get_bool payload - | "transparent_modules" -> - Clflags.transparent_modules := get_bool payload - | "unboxed_types" -> - Migrate_parsetree_compiler_functions.set_unboxed_types (get_bool payload) - | "cookies" -> - let l = get_list (get_pair get_string (fun x -> x)) payload in - cookies := - List.fold_left - (fun s (k, v) -> String.Map.add k v s) String.Map.empty - l - | _ -> - () - in - List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields - - let update_cookies fields = - let fields = - List.filter - (function ({txt=Lident "cookies"}, _) -> false | _ -> true) - fields - in - fields @ [get_cookies ()] - end - - let ppx_context = PpxContext.make - - let extension_of_exn exn = extension_of_error (Locations.location_error_of_exn exn) - (* let extension_of_exn exn = *) - (* match error_of_exn exn with *) - (* | Some (`Ok error) -> extension_of_error error *) - (* | Some `Already_displayed -> *) - (* { loc = Location.none; txt = "ocaml.error" }, PStr [] *) - (* | None -> raise exn *) - - let apply_lazy ~source ~target mapper = - let implem ast = - let fields, ast = - match ast with - | {pstr_desc = Pstr_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.structure mapper ast - with exn -> - [{pstr_desc = Pstr_extension (extension_of_exn exn, []); - pstr_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Str.attribute (PpxContext.mk fields) :: ast - in - let iface ast = - let fields, ast = - match ast with - | {psig_desc = Psig_attribute ({attr_name = {txt = "ocaml.ppx.context"}; - attr_payload = x; - attr_loc = _})} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.signature mapper ast - with exn -> - [{psig_desc = Psig_extension (extension_of_exn exn, []); - psig_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Sig.attribute (PpxContext.mk fields) :: ast - in - - let ic = open_in_bin source in - let magic = - really_input_string ic (String.length Config.ast_impl_magic_number) - in - - let rewrite transform = - Location.input_name := input_value ic; - let ast = input_value ic in - close_in ic; - let ast = transform ast in - let oc = open_out_bin target in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc - and fail () = - close_in ic; - failwith "Ast_mapper: OCaml version mismatch or malformed input"; - in - - if magic = Config.ast_impl_magic_number then - rewrite (implem : structure -> structure) - else if magic = Config.ast_intf_magic_number then - rewrite (iface : signature -> signature) - else fail () - - let drop_ppx_context_str ~restore = function - | {pstr_desc = Pstr_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - - let drop_ppx_context_sig ~restore = function - | {psig_desc = Psig_attribute - {attr_name = {Location.txt = "ocaml.ppx.context"}; - attr_payload = a; - attr_loc = _}} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - - let add_ppx_context_str ~tool_name ast = - Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast - - let add_ppx_context_sig ~tool_name ast = - Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast - - - let apply ~source ~target mapper = - apply_lazy ~source ~target (fun () -> mapper) - - let run_main mapper = - try - let a = Sys.argv in - let n = Array.length a in - if n > 2 then - let mapper () = - try mapper (Array.to_list (Array.sub a 1 (n - 3))) - with exn -> - (* PR#6463 *) - let f _ _ = raise exn in - {default_mapper with structure = f; signature = f} - in - apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper - else begin - Printf.eprintf "Usage: %s [extra_args] \n%!" - Sys.executable_name; - exit 2 - end - with exn -> - prerr_endline (Printexc.to_string exn); - exit 2 + type variance (*IF_CURRENT = Asttypes.variance *) = + | Covariant + | Contravariant + | NoVariance - let register_function = ref (fun _name f -> run_main f) - let register name f = !register_function name f + type injectivity (*IF_CURRENT = Asttypes.injectivity *) = + | Injective + | NoInjectivity end + module Type_immediacy = struct type t (*IF_CURRENT = Type_immediacy.t *) = | Unknown | Always | Always_on_64bits end + module Outcometree = struct (* Module [Outcometree]: results displayed by the toplevel *) @@ -4163,121 +214,3 @@ module Outcometree = struct | Ophr_signature of (out_sig_item * out_value option) list | Ophr_exception of (exn * out_value) end -module Config = struct - let ast_impl_magic_number = "Caml1999M032" - let ast_intf_magic_number = "Caml1999N032" -end - - - -let map_signature mapper = mapper.Ast_mapper.signature mapper -let map_structure mapper = mapper.Ast_mapper.structure mapper - -let shallow_identity = - let id _ x = x in - { - Ast_mapper. - structure = id; - structure_item = id; - module_expr = id; - signature = id; - signature_item = id; - module_type = id; - with_constraint = id; - class_declaration = id; - class_expr = id; - class_field = id; - class_structure = id; - class_type = id; - class_type_field = id; - class_signature = id; - class_type_declaration = id; - class_description = id; - type_declaration = id; - type_kind = id; - typ = id; - type_extension = id; - extension_constructor = id; - value_description = id; - pat = id; - expr = id; - module_declaration = id; - module_type_declaration = id; - module_binding = id; - open_description = id; - include_description = id; - include_declaration = id; - value_binding = id; - constructor_declaration = id; - label_declaration = id; - cases = id; - case = id; - location = id; - extension = id; - attribute = id; - attributes = id; - payload = id; - binding_op = id; - module_substitution = id; - open_declaration = id; - type_exception = id; - constant = id; - } - -let failing_mapper = - let fail _ _ = - invalid_arg "failing_mapper: this mapper function should never get called" - in - { - Ast_mapper. - structure = fail; - structure_item = fail; - module_expr = fail; - signature = fail; - signature_item = fail; - module_type = fail; - with_constraint = fail; - class_declaration = fail; - class_expr = fail; - class_field = fail; - class_structure = fail; - class_type = fail; - class_type_field = fail; - class_signature = fail; - class_type_declaration = fail; - class_description = fail; - type_declaration = fail; - type_kind = fail; - typ = fail; - type_extension = fail; - extension_constructor = fail; - value_description = fail; - pat = fail; - expr = fail; - module_declaration = fail; - module_type_declaration = fail; - module_binding = fail; - open_description = fail; - include_description = fail; - include_declaration = fail; - value_binding = fail; - constructor_declaration = fail; - label_declaration = fail; - cases = fail; - case = fail; - location = fail; - extension = fail; - attribute = fail; - attributes = fail; - payload = fail; - binding_op = fail; - module_substitution = fail; - open_declaration = fail; - type_exception = fail; - constant = fail; - } - -let make_top_mapper ~signature ~structure = - {failing_mapper with Ast_mapper. - signature = (fun _ x -> signature x); - structure = (fun _ x -> structure x) } diff --git a/src/vendored-omp/src/migrate_parsetree_402_403.ml b/src/vendored-omp/src/migrate_parsetree_402_403.ml index b67d68dff..750dc03e0 100644 --- a/src/vendored-omp/src/migrate_parsetree_402_403.ml +++ b/src/vendored-omp/src/migrate_parsetree_402_403.ml @@ -15,116 +15,3 @@ include Migrate_parsetree_402_403_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - (*$*) - payload - } as mapper) -> - let module R = Migrate_parsetree_403_402_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - (*$*) - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload Location.none x))) - } diff --git a/src/vendored-omp/src/migrate_parsetree_402_403_migrate.ml b/src/vendored-omp/src/migrate_parsetree_402_403_migrate.ml index bda5b2f33..f1a84ffc4 100644 --- a/src/vendored-omp/src/migrate_parsetree_402_403_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_402_403_migrate.ml @@ -1,1884 +1,278 @@ -(**************************************************************************) -(* *) -(* OCaml Migrate Parsetree *) -(* *) -(* Frédéric Bour *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2017 Institut National de Recherche en Informatique et *) -(* en Automatique (INRIA). *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - +open Stdlib0 module From = Ast_402 module To = Ast_403 - -let extract_predef_option label typ = - let open From in - let open Longident in - match label, typ.Parsetree.ptyp_desc with - | To.Asttypes.Optional _, - From.Parsetree.Ptyp_constr ( - {Location.txt = Ldot (Lident "*predef*", "option"); _}, [d]) -> - d - | _ -> typ - -let rec copy_expression : - From.Parsetree.expression -> - To.Parsetree.expression +let rec copy_out_type_extension : + Ast_402.Outcometree.out_type_extension -> + Ast_403.Outcometree.out_type_extension = fun - { From.Parsetree.pexp_desc = pexp_desc; - From.Parsetree.pexp_loc = pexp_loc; - From.Parsetree.pexp_attributes = pexp_attributes } - -> + { Ast_402.Outcometree.otyext_name = otyext_name; + Ast_402.Outcometree.otyext_params = otyext_params; + Ast_402.Outcometree.otyext_constructors = otyext_constructors; + Ast_402.Outcometree.otyext_private = otyext_private } + -> { - To.Parsetree.pexp_desc = - (copy_expression_desc pexp_desc); - To.Parsetree.pexp_loc = - (copy_location pexp_loc); - To.Parsetree.pexp_attributes = - (copy_attributes pexp_attributes) - } - -and copy_expression_desc : - From.Parsetree.expression_desc -> - To.Parsetree.expression_desc - = - function - | From.Parsetree.Pexp_ident x0 -> - To.Parsetree.Pexp_ident - (copy_loc copy_longident - x0) - | From.Parsetree.Pexp_constant x0 -> - To.Parsetree.Pexp_constant - (copy_constant x0) - | From.Parsetree.Pexp_let (x0,x1,x2) -> - To.Parsetree.Pexp_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_expression x2)) - | From.Parsetree.Pexp_function x0 -> - To.Parsetree.Pexp_function - (List.map copy_case x0) - | From.Parsetree.Pexp_fun (x0,x1,x2,x3) -> - To.Parsetree.Pexp_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_expression x3)) - | From.Parsetree.Pexp_apply (x0,x1) -> - To.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pexp_match (x0,x1) -> - To.Parsetree.Pexp_match - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_try (x0,x1) -> - To.Parsetree.Pexp_try - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_tuple x0 -> - To.Parsetree.Pexp_tuple - (List.map copy_expression x0) - | From.Parsetree.Pexp_construct (x0,x1) -> - To.Parsetree.Pexp_construct - ((copy_loc - copy_longident x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_variant (x0,x1) -> - To.Parsetree.Pexp_variant - ((copy_label x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_record (x0,x1) -> - To.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc - copy_longident x0), - (copy_expression x1))) x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_field (x0,x1) -> - To.Parsetree.Pexp_field - ((copy_expression x0), - (copy_loc - copy_longident x1)) - | From.Parsetree.Pexp_setfield (x0,x1,x2) -> - To.Parsetree.Pexp_setfield - ((copy_expression x0), - (copy_loc - copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_array x0 -> - To.Parsetree.Pexp_array - (List.map copy_expression x0) - | From.Parsetree.Pexp_ifthenelse (x0,x1,x2) -> - To.Parsetree.Pexp_ifthenelse - ((copy_expression x0), - (copy_expression x1), - (copy_option copy_expression x2)) - | From.Parsetree.Pexp_sequence (x0,x1) -> - To.Parsetree.Pexp_sequence - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_while (x0,x1) -> - To.Parsetree.Pexp_while - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_for (x0,x1,x2,x3,x4) -> - To.Parsetree.Pexp_for - ((copy_pattern x0), - (copy_expression x1), - (copy_expression x2), - (copy_direction_flag x3), - (copy_expression x4)) - | From.Parsetree.Pexp_constraint (x0,x1) -> - To.Parsetree.Pexp_constraint - ((copy_expression x0), - (copy_core_type x1)) - | From.Parsetree.Pexp_coerce (x0,x1,x2) -> - To.Parsetree.Pexp_coerce - ((copy_expression x0), - (copy_option copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Pexp_send (x0,x1) -> - To.Parsetree.Pexp_send - ((copy_expression x0), x1) - | From.Parsetree.Pexp_new x0 -> - To.Parsetree.Pexp_new - (copy_loc copy_longident - x0) - | From.Parsetree.Pexp_setinstvar (x0,x1) -> - To.Parsetree.Pexp_setinstvar - ((copy_loc (fun x -> x) x0), - (copy_expression x1)) - | From.Parsetree.Pexp_override x0 -> - To.Parsetree.Pexp_override + Ast_403.Outcometree.otyext_name = otyext_name; + Ast_403.Outcometree.otyext_params = + (List.map (fun x -> x) otyext_params); + Ast_403.Outcometree.otyext_constructors = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_expression x1))) x0) - | From.Parsetree.Pexp_letmodule (x0,x1,x2) -> - To.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> x) x0), - (copy_module_expr x1), - (copy_expression x2)) - | From.Parsetree.Pexp_assert x0 -> - To.Parsetree.Pexp_assert - (copy_expression x0) - | From.Parsetree.Pexp_lazy x0 -> - To.Parsetree.Pexp_lazy - (copy_expression x0) - | From.Parsetree.Pexp_poly (x0,x1) -> - To.Parsetree.Pexp_poly - ((copy_expression x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pexp_object x0 -> - To.Parsetree.Pexp_object - (copy_class_structure x0) - | From.Parsetree.Pexp_newtype (x0,x1) -> - To.Parsetree.Pexp_newtype - (x0, (copy_expression x1)) - | From.Parsetree.Pexp_pack x0 -> - To.Parsetree.Pexp_pack - (copy_module_expr x0) - | From.Parsetree.Pexp_open (x0,x1,x2) -> - To.Parsetree.Pexp_open - ((copy_override_flag x0), - (copy_loc - copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_extension x0 -> - To.Parsetree.Pexp_extension - (copy_extension x0) - -and copy_direction_flag : - From.Asttypes.direction_flag -> - To.Asttypes.direction_flag - = - function - | From.Asttypes.Upto -> To.Asttypes.Upto - | From.Asttypes.Downto -> To.Asttypes.Downto - -and copy_case : - From.Parsetree.case -> To.Parsetree.case = - fun - { From.Parsetree.pc_lhs = pc_lhs; - From.Parsetree.pc_guard = pc_guard; - From.Parsetree.pc_rhs = pc_rhs } - -> - { - To.Parsetree.pc_lhs = - (copy_pattern pc_lhs); - To.Parsetree.pc_guard = - (copy_option copy_expression pc_guard); - To.Parsetree.pc_rhs = - (copy_expression pc_rhs) - } - -and copy_value_binding : - From.Parsetree.value_binding -> - To.Parsetree.value_binding - = - fun - { From.Parsetree.pvb_pat = pvb_pat; - From.Parsetree.pvb_expr = pvb_expr; - From.Parsetree.pvb_attributes = pvb_attributes; - From.Parsetree.pvb_loc = pvb_loc } - -> - { - To.Parsetree.pvb_pat = - (copy_pattern pvb_pat); - To.Parsetree.pvb_expr = - (copy_expression pvb_expr); - To.Parsetree.pvb_attributes = - (copy_attributes pvb_attributes); - To.Parsetree.pvb_loc = - (copy_location pvb_loc) - } - -and copy_pattern : - From.Parsetree.pattern -> To.Parsetree.pattern = - fun - { From.Parsetree.ppat_desc = ppat_desc; - From.Parsetree.ppat_loc = ppat_loc; - From.Parsetree.ppat_attributes = ppat_attributes } - -> - { - To.Parsetree.ppat_desc = - (copy_pattern_desc ppat_desc); - To.Parsetree.ppat_loc = - (copy_location ppat_loc); - To.Parsetree.ppat_attributes = - (copy_attributes ppat_attributes) - } - -and copy_pattern_desc : - From.Parsetree.pattern_desc -> - To.Parsetree.pattern_desc - = - function - | From.Parsetree.Ppat_any -> - To.Parsetree.Ppat_any - | From.Parsetree.Ppat_var x0 -> - To.Parsetree.Ppat_var - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_alias (x0,x1) -> - To.Parsetree.Ppat_alias - ((copy_pattern x0), - (copy_loc (fun x -> x) x1)) - | From.Parsetree.Ppat_constant x0 -> - To.Parsetree.Ppat_constant - (copy_constant x0) - | From.Parsetree.Ppat_interval (x0,x1) -> - To.Parsetree.Ppat_interval - ((copy_constant x0), - (copy_constant x1)) - | From.Parsetree.Ppat_tuple x0 -> - To.Parsetree.Ppat_tuple - (List.map copy_pattern x0) - | From.Parsetree.Ppat_construct (x0,x1) -> - To.Parsetree.Ppat_construct - ((copy_loc - copy_longident x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_variant (x0,x1) -> - To.Parsetree.Ppat_variant - ((copy_label x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_record (x0,x1) -> - To.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc - copy_longident x0), - (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ppat_array x0 -> - To.Parsetree.Ppat_array - (List.map copy_pattern x0) - | From.Parsetree.Ppat_or (x0,x1) -> - To.Parsetree.Ppat_or - ((copy_pattern x0), - (copy_pattern x1)) - | From.Parsetree.Ppat_constraint (x0,x1) -> - To.Parsetree.Ppat_constraint - ((copy_pattern x0), - (copy_core_type x1)) - | From.Parsetree.Ppat_type x0 -> - To.Parsetree.Ppat_type - (copy_loc copy_longident - x0) - | From.Parsetree.Ppat_lazy x0 -> - To.Parsetree.Ppat_lazy - (copy_pattern x0) - | From.Parsetree.Ppat_unpack x0 -> - To.Parsetree.Ppat_unpack - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_exception x0 -> - To.Parsetree.Ppat_exception - (copy_pattern x0) - | From.Parsetree.Ppat_extension x0 -> - To.Parsetree.Ppat_extension - (copy_extension x0) - -and copy_core_type : - From.Parsetree.core_type -> - To.Parsetree.core_type - = - fun - { From.Parsetree.ptyp_desc = ptyp_desc; - From.Parsetree.ptyp_loc = ptyp_loc; - From.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - To.Parsetree.ptyp_desc = - (copy_core_type_desc ptyp_desc); - To.Parsetree.ptyp_loc = - (copy_location ptyp_loc); - To.Parsetree.ptyp_attributes = - (copy_attributes ptyp_attributes) - } - -and copy_core_type_desc : - From.Parsetree.core_type_desc -> - To.Parsetree.core_type_desc - = - function - | From.Parsetree.Ptyp_any -> - To.Parsetree.Ptyp_any - | From.Parsetree.Ptyp_var x0 -> - To.Parsetree.Ptyp_var x0 - | From.Parsetree.Ptyp_arrow (x0,x1,x2) -> - let label = copy_arg_label x0 in - To.Parsetree.Ptyp_arrow - (label, - copy_core_type (extract_predef_option label x1), - copy_core_type x2) - | From.Parsetree.Ptyp_tuple x0 -> - To.Parsetree.Ptyp_tuple - (List.map copy_core_type x0) - | From.Parsetree.Ptyp_constr (x0,x1) -> - To.Parsetree.Ptyp_constr - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_object (x0,x1) -> - To.Parsetree.Ptyp_object - ((List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_attributes x1), - (copy_core_type x2))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ptyp_class (x0,x1) -> - To.Parsetree.Ptyp_class - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_alias (x0,x1) -> - To.Parsetree.Ptyp_alias - ((copy_core_type x0), x1) - | From.Parsetree.Ptyp_variant (x0,x1,x2) -> - To.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), - (copy_closed_flag x1), - (copy_option - (fun x -> List.map copy_label x) x2)) - | From.Parsetree.Ptyp_poly (x0,x1) -> - To.Parsetree.Ptyp_poly - ((List.map (fun x -> x) x0), - (copy_core_type x1)) - | From.Parsetree.Ptyp_package x0 -> - To.Parsetree.Ptyp_package - (copy_package_type x0) - | From.Parsetree.Ptyp_extension x0 -> - To.Parsetree.Ptyp_extension - (copy_extension x0) - -and copy_package_type : - From.Parsetree.package_type -> - To.Parsetree.package_type - = - fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc - copy_longident x0), - (copy_core_type x1))) x1)) - -and copy_row_field : - From.Parsetree.row_field -> - To.Parsetree.row_field - = - function - | From.Parsetree.Rtag (x0,x1,x2,x3) -> - To.Parsetree.Rtag - ((copy_label x0), - (copy_attributes x1), (copy_bool x2), - (List.map copy_core_type x3)) - | From.Parsetree.Rinherit x0 -> - To.Parsetree.Rinherit - (copy_core_type x0) - -and copy_attributes : - From.Parsetree.attributes -> - To.Parsetree.attributes - = fun x -> List.map copy_attribute x - -and copy_attribute : - From.Parsetree.attribute -> - To.Parsetree.attribute - = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_payload : - From.Parsetree.payload -> To.Parsetree.payload = - function - | From.Parsetree.PStr x0 -> - To.Parsetree.PStr - (copy_structure x0) - | From.Parsetree.PTyp x0 -> - To.Parsetree.PTyp - (copy_core_type x0) - | From.Parsetree.PPat (x0,x1) -> - To.Parsetree.PPat - ((copy_pattern x0), - (copy_option copy_expression x1)) - -and copy_structure : - From.Parsetree.structure -> - To.Parsetree.structure - = fun x -> List.map copy_structure_item x - -and copy_structure_item : - From.Parsetree.structure_item -> - To.Parsetree.structure_item - = - fun - { From.Parsetree.pstr_desc = pstr_desc; - From.Parsetree.pstr_loc = pstr_loc } - -> - { - To.Parsetree.pstr_desc = - (copy_structure_item_desc pstr_desc); - To.Parsetree.pstr_loc = - (copy_location pstr_loc) - } - -and copy_structure_item_desc : - From.Parsetree.structure_item_desc -> - To.Parsetree.structure_item_desc - = - function - | From.Parsetree.Pstr_eval (x0,x1) -> - To.Parsetree.Pstr_eval - ((copy_expression x0), - (copy_attributes x1)) - | From.Parsetree.Pstr_value (x0,x1) -> - To.Parsetree.Pstr_value - ((copy_rec_flag x0), - (List.map copy_value_binding x1)) - | From.Parsetree.Pstr_primitive x0 -> - To.Parsetree.Pstr_primitive - (copy_value_description x0) - | From.Parsetree.Pstr_type x0 -> - let recflag, types = type_declarations x0 in - To.Parsetree.Pstr_type (recflag, types) - | From.Parsetree.Pstr_typext x0 -> - To.Parsetree.Pstr_typext - (copy_type_extension x0) - | From.Parsetree.Pstr_exception x0 -> - To.Parsetree.Pstr_exception - (copy_extension_constructor x0) - | From.Parsetree.Pstr_module x0 -> - To.Parsetree.Pstr_module - (copy_module_binding x0) - | From.Parsetree.Pstr_recmodule x0 -> - To.Parsetree.Pstr_recmodule - (List.map copy_module_binding x0) - | From.Parsetree.Pstr_modtype x0 -> - To.Parsetree.Pstr_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Pstr_open x0 -> - To.Parsetree.Pstr_open - (copy_open_description x0) - | From.Parsetree.Pstr_class x0 -> - To.Parsetree.Pstr_class - (List.map copy_class_declaration x0) - | From.Parsetree.Pstr_class_type x0 -> - To.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Pstr_include x0 -> - To.Parsetree.Pstr_include - (copy_include_declaration x0) - | From.Parsetree.Pstr_attribute x0 -> - To.Parsetree.Pstr_attribute - (copy_attribute x0) - | From.Parsetree.Pstr_extension (x0,x1) -> - To.Parsetree.Pstr_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_include_declaration : - From.Parsetree.include_declaration -> - To.Parsetree.include_declaration - = - fun x -> - copy_include_infos - copy_module_expr x - -and copy_class_declaration : - From.Parsetree.class_declaration -> - To.Parsetree.class_declaration - = - fun x -> - copy_class_infos - copy_class_expr x - -and copy_class_expr : - From.Parsetree.class_expr -> - To.Parsetree.class_expr - = - fun - { From.Parsetree.pcl_desc = pcl_desc; - From.Parsetree.pcl_loc = pcl_loc; - From.Parsetree.pcl_attributes = pcl_attributes } - -> - { - To.Parsetree.pcl_desc = - (copy_class_expr_desc pcl_desc); - To.Parsetree.pcl_loc = - (copy_location pcl_loc); - To.Parsetree.pcl_attributes = - (copy_attributes pcl_attributes) - } - -and copy_class_expr_desc : - From.Parsetree.class_expr_desc -> - To.Parsetree.class_expr_desc - = - function - | From.Parsetree.Pcl_constr (x0,x1) -> - To.Parsetree.Pcl_constr - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcl_structure x0 -> - To.Parsetree.Pcl_structure - (copy_class_structure x0) - | From.Parsetree.Pcl_fun (x0,x1,x2,x3) -> - To.Parsetree.Pcl_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_class_expr x3)) - | From.Parsetree.Pcl_apply (x0,x1) -> - To.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pcl_let (x0,x1,x2) -> - To.Parsetree.Pcl_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_class_expr x2)) - | From.Parsetree.Pcl_constraint (x0,x1) -> - To.Parsetree.Pcl_constraint - ((copy_class_expr x0), - (copy_class_type x1)) - | From.Parsetree.Pcl_extension x0 -> - To.Parsetree.Pcl_extension - (copy_extension x0) - -and copy_class_structure : - From.Parsetree.class_structure -> - To.Parsetree.class_structure - = - fun - { From.Parsetree.pcstr_self = pcstr_self; - From.Parsetree.pcstr_fields = pcstr_fields } - -> - { - To.Parsetree.pcstr_self = - (copy_pattern pcstr_self); - To.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } - -and copy_class_field : - From.Parsetree.class_field -> - To.Parsetree.class_field - = - fun - { From.Parsetree.pcf_desc = pcf_desc; - From.Parsetree.pcf_loc = pcf_loc; - From.Parsetree.pcf_attributes = pcf_attributes } - -> - { - To.Parsetree.pcf_desc = - (copy_class_field_desc pcf_desc); - To.Parsetree.pcf_loc = - (copy_location pcf_loc); - To.Parsetree.pcf_attributes = - (copy_attributes pcf_attributes) - } - -and copy_class_field_desc : - From.Parsetree.class_field_desc -> - To.Parsetree.class_field_desc - = - function - | From.Parsetree.Pcf_inherit (x0,x1,x2) -> - To.Parsetree.Pcf_inherit - ((copy_override_flag x0), - (copy_class_expr x1), - (copy_option (fun x -> x) x2)) - | From.Parsetree.Pcf_val x0 -> - To.Parsetree.Pcf_val - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_method x0 -> - To.Parsetree.Pcf_method - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_private_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_constraint x0 -> - To.Parsetree.Pcf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pcf_initializer x0 -> - To.Parsetree.Pcf_initializer - (copy_expression x0) - | From.Parsetree.Pcf_attribute x0 -> - To.Parsetree.Pcf_attribute - (copy_attribute x0) - | From.Parsetree.Pcf_extension x0 -> - To.Parsetree.Pcf_extension - (copy_extension x0) - -and copy_class_field_kind : - From.Parsetree.class_field_kind -> - To.Parsetree.class_field_kind - = - function - | From.Parsetree.Cfk_virtual x0 -> - To.Parsetree.Cfk_virtual - (copy_core_type x0) - | From.Parsetree.Cfk_concrete (x0,x1) -> - To.Parsetree.Cfk_concrete - ((copy_override_flag x0), - (copy_expression x1)) - -and copy_module_binding : - From.Parsetree.module_binding -> - To.Parsetree.module_binding - = - fun - { From.Parsetree.pmb_name = pmb_name; - From.Parsetree.pmb_expr = pmb_expr; - From.Parsetree.pmb_attributes = pmb_attributes; - From.Parsetree.pmb_loc = pmb_loc } - -> - { - To.Parsetree.pmb_name = - (copy_loc (fun x -> x) pmb_name); - To.Parsetree.pmb_expr = - (copy_module_expr pmb_expr); - To.Parsetree.pmb_attributes = - (copy_attributes pmb_attributes); - To.Parsetree.pmb_loc = - (copy_location pmb_loc) - } - -and copy_module_expr : - From.Parsetree.module_expr -> - To.Parsetree.module_expr - = - fun - { From.Parsetree.pmod_desc = pmod_desc; - From.Parsetree.pmod_loc = pmod_loc; - From.Parsetree.pmod_attributes = pmod_attributes } - -> - { - To.Parsetree.pmod_desc = - (copy_module_expr_desc pmod_desc); - To.Parsetree.pmod_loc = - (copy_location pmod_loc); - To.Parsetree.pmod_attributes = - (copy_attributes pmod_attributes) - } - -and copy_module_expr_desc : - From.Parsetree.module_expr_desc -> - To.Parsetree.module_expr_desc - = - function - | From.Parsetree.Pmod_ident x0 -> - To.Parsetree.Pmod_ident - (copy_loc copy_longident - x0) - | From.Parsetree.Pmod_structure x0 -> - To.Parsetree.Pmod_structure - (copy_structure x0) - | From.Parsetree.Pmod_functor (x0,x1,x2) -> - To.Parsetree.Pmod_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_expr x2)) - | From.Parsetree.Pmod_apply (x0,x1) -> - To.Parsetree.Pmod_apply - ((copy_module_expr x0), - (copy_module_expr x1)) - | From.Parsetree.Pmod_constraint (x0,x1) -> - To.Parsetree.Pmod_constraint - ((copy_module_expr x0), - (copy_module_type x1)) - | From.Parsetree.Pmod_unpack x0 -> - To.Parsetree.Pmod_unpack - (copy_expression x0) - | From.Parsetree.Pmod_extension x0 -> - To.Parsetree.Pmod_extension - (copy_extension x0) - -and copy_module_type : - From.Parsetree.module_type -> - To.Parsetree.module_type - = - fun - { From.Parsetree.pmty_desc = pmty_desc; - From.Parsetree.pmty_loc = pmty_loc; - From.Parsetree.pmty_attributes = pmty_attributes } - -> - { - To.Parsetree.pmty_desc = - (copy_module_type_desc pmty_desc); - To.Parsetree.pmty_loc = - (copy_location pmty_loc); - To.Parsetree.pmty_attributes = - (copy_attributes pmty_attributes) - } - -and copy_module_type_desc : - From.Parsetree.module_type_desc -> - To.Parsetree.module_type_desc - = - function - | From.Parsetree.Pmty_ident x0 -> - To.Parsetree.Pmty_ident - (copy_loc copy_longident - x0) - | From.Parsetree.Pmty_signature x0 -> - To.Parsetree.Pmty_signature - (copy_signature x0) - | From.Parsetree.Pmty_functor (x0,x1,x2) -> - To.Parsetree.Pmty_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_type x2)) - | From.Parsetree.Pmty_with (x0,x1) -> - To.Parsetree.Pmty_with - ((copy_module_type x0), - (List.map copy_with_constraint x1)) - | From.Parsetree.Pmty_typeof x0 -> - To.Parsetree.Pmty_typeof - (copy_module_expr x0) - | From.Parsetree.Pmty_extension x0 -> - To.Parsetree.Pmty_extension - (copy_extension x0) - | From.Parsetree.Pmty_alias x0 -> - To.Parsetree.Pmty_alias - (copy_loc copy_longident - x0) - -and copy_with_constraint : - From.Parsetree.with_constraint -> - To.Parsetree.with_constraint - = - function - | From.Parsetree.Pwith_type (x0,x1) -> - To.Parsetree.Pwith_type - ((copy_loc - copy_longident x0), - (copy_type_declaration x1)) - | From.Parsetree.Pwith_module (x0,x1) -> - To.Parsetree.Pwith_module - ((copy_loc - copy_longident x0), - (copy_loc - copy_longident x1)) - | From.Parsetree.Pwith_typesubst x0 -> - To.Parsetree.Pwith_typesubst - (copy_type_declaration x0) - | From.Parsetree.Pwith_modsubst (x0,x1) -> - To.Parsetree.Pwith_modsubst - ((copy_loc (fun x -> x) x0), - (copy_loc - copy_longident x1)) - -and copy_signature : - From.Parsetree.signature -> - To.Parsetree.signature - = fun x -> List.map copy_signature_item x - -and copy_signature_item : - From.Parsetree.signature_item -> - To.Parsetree.signature_item - = - fun - { From.Parsetree.psig_desc = psig_desc; - From.Parsetree.psig_loc = psig_loc } - -> - { - To.Parsetree.psig_desc = - (copy_signature_item_desc psig_desc); - To.Parsetree.psig_loc = - (copy_location psig_loc) - } - -and copy_signature_item_desc : - From.Parsetree.signature_item_desc -> - To.Parsetree.signature_item_desc - = - function - | From.Parsetree.Psig_value x0 -> - To.Parsetree.Psig_value - (copy_value_description x0) - | From.Parsetree.Psig_type x0 -> - let recflag, types = type_declarations x0 in - To.Parsetree.Psig_type (recflag, types) - | From.Parsetree.Psig_typext x0 -> - To.Parsetree.Psig_typext - (copy_type_extension x0) - | From.Parsetree.Psig_exception x0 -> - To.Parsetree.Psig_exception - (copy_extension_constructor x0) - | From.Parsetree.Psig_module x0 -> - To.Parsetree.Psig_module - (copy_module_declaration x0) - | From.Parsetree.Psig_recmodule x0 -> - To.Parsetree.Psig_recmodule - (List.map copy_module_declaration x0) - | From.Parsetree.Psig_modtype x0 -> - To.Parsetree.Psig_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Psig_open x0 -> - To.Parsetree.Psig_open - (copy_open_description x0) - | From.Parsetree.Psig_include x0 -> - To.Parsetree.Psig_include - (copy_include_description x0) - | From.Parsetree.Psig_class x0 -> - To.Parsetree.Psig_class - (List.map copy_class_description x0) - | From.Parsetree.Psig_class_type x0 -> - To.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Psig_attribute x0 -> - To.Parsetree.Psig_attribute - (copy_attribute x0) - | From.Parsetree.Psig_extension (x0,x1) -> - To.Parsetree.Psig_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_class_type_declaration : - From.Parsetree.class_type_declaration -> - To.Parsetree.class_type_declaration - = - fun x -> - copy_class_infos - copy_class_type x - -and copy_class_description : - From.Parsetree.class_description -> - To.Parsetree.class_description - = - fun x -> - copy_class_infos - copy_class_type x - -and copy_class_type : - From.Parsetree.class_type -> - To.Parsetree.class_type - = - fun - { From.Parsetree.pcty_desc = pcty_desc; - From.Parsetree.pcty_loc = pcty_loc; - From.Parsetree.pcty_attributes = pcty_attributes } - -> - { - To.Parsetree.pcty_desc = - (copy_class_type_desc pcty_desc); - To.Parsetree.pcty_loc = - (copy_location pcty_loc); - To.Parsetree.pcty_attributes = - (copy_attributes pcty_attributes) - } - -and copy_class_type_desc : - From.Parsetree.class_type_desc -> - To.Parsetree.class_type_desc - = - function - | From.Parsetree.Pcty_constr (x0,x1) -> - To.Parsetree.Pcty_constr - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcty_signature x0 -> - To.Parsetree.Pcty_signature - (copy_class_signature x0) - | From.Parsetree.Pcty_arrow (x0,x1,x2) -> - let label = copy_arg_label x0 in - To.Parsetree.Pcty_arrow - (label, - copy_core_type (extract_predef_option label x1), - copy_class_type x2) - | From.Parsetree.Pcty_extension x0 -> - To.Parsetree.Pcty_extension - (copy_extension x0) - -and copy_class_signature : - From.Parsetree.class_signature -> - To.Parsetree.class_signature - = - fun - { From.Parsetree.pcsig_self = pcsig_self; - From.Parsetree.pcsig_fields = pcsig_fields } - -> - { - To.Parsetree.pcsig_self = - (copy_core_type pcsig_self); - To.Parsetree.pcsig_fields = - (List.map copy_class_type_field - pcsig_fields) - } - -and copy_class_type_field : - From.Parsetree.class_type_field -> - To.Parsetree.class_type_field - = - fun - { From.Parsetree.pctf_desc = pctf_desc; - From.Parsetree.pctf_loc = pctf_loc; - From.Parsetree.pctf_attributes = pctf_attributes } - -> - { - To.Parsetree.pctf_desc = - (copy_class_type_field_desc pctf_desc); - To.Parsetree.pctf_loc = - (copy_location pctf_loc); - To.Parsetree.pctf_attributes = - (copy_attributes pctf_attributes) - } - -and copy_class_type_field_desc : - From.Parsetree.class_type_field_desc -> - To.Parsetree.class_type_field_desc - = - function - | From.Parsetree.Pctf_inherit x0 -> - To.Parsetree.Pctf_inherit - (copy_class_type x0) - | From.Parsetree.Pctf_val x0 -> - To.Parsetree.Pctf_val - (let (x0,x1,x2,x3) = x0 in - (x0, (copy_mutable_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_method x0 -> - To.Parsetree.Pctf_method - (let (x0,x1,x2,x3) = x0 in - (x0, (copy_private_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_constraint x0 -> - To.Parsetree.Pctf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pctf_attribute x0 -> - To.Parsetree.Pctf_attribute - (copy_attribute x0) - | From.Parsetree.Pctf_extension x0 -> - To.Parsetree.Pctf_extension - (copy_extension x0) - -and copy_extension : - From.Parsetree.extension -> - To.Parsetree.extension - = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.class_infos -> - 'g0 To.Parsetree.class_infos - = - fun f0 -> - fun - { From.Parsetree.pci_virt = pci_virt; - From.Parsetree.pci_params = pci_params; - From.Parsetree.pci_name = pci_name; - From.Parsetree.pci_expr = pci_expr; - From.Parsetree.pci_loc = pci_loc; - From.Parsetree.pci_attributes = pci_attributes } - -> - { - To.Parsetree.pci_virt = - (copy_virtual_flag pci_virt); - To.Parsetree.pci_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) pci_params); - To.Parsetree.pci_name = - (copy_loc (fun x -> x) pci_name); - To.Parsetree.pci_expr = (f0 pci_expr); - To.Parsetree.pci_loc = - (copy_location pci_loc); - To.Parsetree.pci_attributes = - (copy_attributes pci_attributes) - } - -and copy_virtual_flag : - From.Asttypes.virtual_flag -> - To.Asttypes.virtual_flag - = - function - | From.Asttypes.Virtual -> To.Asttypes.Virtual - | From.Asttypes.Concrete -> To.Asttypes.Concrete - -and copy_include_description : - From.Parsetree.include_description -> - To.Parsetree.include_description - = - fun x -> - copy_include_infos - copy_module_type x - -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.include_infos -> - 'g0 To.Parsetree.include_infos - = - fun f0 -> - fun - { From.Parsetree.pincl_mod = pincl_mod; - From.Parsetree.pincl_loc = pincl_loc; - From.Parsetree.pincl_attributes = pincl_attributes } - -> - { - To.Parsetree.pincl_mod = (f0 pincl_mod); - To.Parsetree.pincl_loc = - (copy_location pincl_loc); - To.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } - -and copy_open_description : - From.Parsetree.open_description -> - To.Parsetree.open_description - = - fun - { From.Parsetree.popen_lid = popen_lid; - From.Parsetree.popen_override = popen_override; - From.Parsetree.popen_loc = popen_loc; - From.Parsetree.popen_attributes = popen_attributes } - -> - { - To.Parsetree.popen_lid = - (copy_loc copy_longident - popen_lid); - To.Parsetree.popen_override = - (copy_override_flag popen_override); - To.Parsetree.popen_loc = - (copy_location popen_loc); - To.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } - -and copy_override_flag : - From.Asttypes.override_flag -> - To.Asttypes.override_flag - = - function - | From.Asttypes.Override -> To.Asttypes.Override - | From.Asttypes.Fresh -> To.Asttypes.Fresh - -and copy_module_type_declaration : - From.Parsetree.module_type_declaration -> - To.Parsetree.module_type_declaration - = - fun - { From.Parsetree.pmtd_name = pmtd_name; - From.Parsetree.pmtd_type = pmtd_type; - From.Parsetree.pmtd_attributes = pmtd_attributes; - From.Parsetree.pmtd_loc = pmtd_loc } - -> - { - To.Parsetree.pmtd_name = - (copy_loc (fun x -> x) pmtd_name); - To.Parsetree.pmtd_type = - (copy_option copy_module_type pmtd_type); - To.Parsetree.pmtd_attributes = - (copy_attributes pmtd_attributes); - To.Parsetree.pmtd_loc = - (copy_location pmtd_loc) - } - -and copy_module_declaration : - From.Parsetree.module_declaration -> - To.Parsetree.module_declaration - = - fun - { From.Parsetree.pmd_name = pmd_name; - From.Parsetree.pmd_type = pmd_type; - From.Parsetree.pmd_attributes = pmd_attributes; - From.Parsetree.pmd_loc = pmd_loc } - -> - { - To.Parsetree.pmd_name = - (copy_loc (fun x -> x) pmd_name); - To.Parsetree.pmd_type = - (copy_module_type pmd_type); - To.Parsetree.pmd_attributes = - (copy_attributes pmd_attributes); - To.Parsetree.pmd_loc = - (copy_location pmd_loc) - } - -and copy_type_extension : - From.Parsetree.type_extension -> - To.Parsetree.type_extension - = - fun - { From.Parsetree.ptyext_path = ptyext_path; - From.Parsetree.ptyext_params = ptyext_params; - From.Parsetree.ptyext_constructors = ptyext_constructors; - From.Parsetree.ptyext_private = ptyext_private; - From.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - To.Parsetree.ptyext_path = - (copy_loc copy_longident - ptyext_path); - To.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptyext_params); - To.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor - ptyext_constructors); - To.Parsetree.ptyext_private = - (copy_private_flag ptyext_private); - To.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } - -and copy_extension_constructor : - From.Parsetree.extension_constructor -> - To.Parsetree.extension_constructor - = - fun - { From.Parsetree.pext_name = pext_name; - From.Parsetree.pext_kind = pext_kind; - From.Parsetree.pext_loc = pext_loc; - From.Parsetree.pext_attributes = pext_attributes } - -> - { - To.Parsetree.pext_name = - (copy_loc (fun x -> x) pext_name); - To.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - To.Parsetree.pext_loc = - (copy_location pext_loc); - To.Parsetree.pext_attributes = - (copy_attributes pext_attributes) - } - -and copy_extension_constructor_kind : - From.Parsetree.extension_constructor_kind -> - To.Parsetree.extension_constructor_kind - = - function - | From.Parsetree.Pext_decl (x0,x1) -> - To.Parsetree.Pext_decl - (To.Parsetree.Pcstr_tuple (List.map copy_core_type x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pext_rebind x0 -> - To.Parsetree.Pext_rebind - (copy_loc copy_longident - x0) - -and copy_type_declaration : - From.Parsetree.type_declaration -> - To.Parsetree.type_declaration - = - fun - { From.Parsetree.ptype_name = ptype_name; - From.Parsetree.ptype_params = ptype_params; - From.Parsetree.ptype_cstrs = ptype_cstrs; - From.Parsetree.ptype_kind = ptype_kind; - From.Parsetree.ptype_private = ptype_private; - From.Parsetree.ptype_manifest = ptype_manifest; - From.Parsetree.ptype_attributes = ptype_attributes; - From.Parsetree.ptype_loc = ptype_loc } - -> - { - To.Parsetree.ptype_name = - (copy_loc (fun x -> x) ptype_name); - To.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptype_params); - To.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0,x1,x2) = x in - ((copy_core_type x0), - (copy_core_type x1), - (copy_location x2))) ptype_cstrs); - To.Parsetree.ptype_kind = - (copy_type_kind ptype_kind); - To.Parsetree.ptype_private = - (copy_private_flag ptype_private); - To.Parsetree.ptype_manifest = - (copy_option copy_core_type ptype_manifest); - To.Parsetree.ptype_attributes = - (copy_attributes ptype_attributes); - To.Parsetree.ptype_loc = - (copy_location ptype_loc) - } - -and copy_private_flag : - From.Asttypes.private_flag -> - To.Asttypes.private_flag - = - function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - -and copy_type_kind : - From.Parsetree.type_kind -> - To.Parsetree.type_kind - = - function - | From.Parsetree.Ptype_abstract -> - To.Parsetree.Ptype_abstract - | From.Parsetree.Ptype_variant x0 -> - To.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | From.Parsetree.Ptype_record x0 -> - To.Parsetree.Ptype_record - (List.map copy_label_declaration x0) - | From.Parsetree.Ptype_open -> - To.Parsetree.Ptype_open - -and copy_label_declaration : - From.Parsetree.label_declaration -> - To.Parsetree.label_declaration - = - fun - { From.Parsetree.pld_name = pld_name; - From.Parsetree.pld_mutable = pld_mutable; - From.Parsetree.pld_type = pld_type; - From.Parsetree.pld_loc = pld_loc; - From.Parsetree.pld_attributes = pld_attributes } - -> - { - To.Parsetree.pld_name = - (copy_loc (fun x -> x) pld_name); - To.Parsetree.pld_mutable = - (copy_mutable_flag pld_mutable); - To.Parsetree.pld_type = - (copy_core_type pld_type); - To.Parsetree.pld_loc = - (copy_location pld_loc); - To.Parsetree.pld_attributes = - (copy_attributes pld_attributes) - } - -and copy_mutable_flag : - From.Asttypes.mutable_flag -> - To.Asttypes.mutable_flag - = - function - | From.Asttypes.Immutable -> - To.Asttypes.Immutable - | From.Asttypes.Mutable -> To.Asttypes.Mutable - -and copy_constructor_declaration : - From.Parsetree.constructor_declaration -> - To.Parsetree.constructor_declaration - = - fun - { From.Parsetree.pcd_name = pcd_name; - From.Parsetree.pcd_args = pcd_args; - From.Parsetree.pcd_res = pcd_res; - From.Parsetree.pcd_loc = pcd_loc; - From.Parsetree.pcd_attributes = pcd_attributes } - -> - { - To.Parsetree.pcd_name = - (copy_loc (fun x -> x) pcd_name); - To.Parsetree.pcd_args = - To.Parsetree.Pcstr_tuple (List.map copy_core_type pcd_args); - To.Parsetree.pcd_res = - (copy_option copy_core_type pcd_res); - To.Parsetree.pcd_loc = - (copy_location pcd_loc); - To.Parsetree.pcd_attributes = - (copy_attributes pcd_attributes) - } - -and copy_variance : - From.Asttypes.variance -> To.Asttypes.variance = - function - | From.Asttypes.Covariant -> - To.Asttypes.Covariant - | From.Asttypes.Contravariant -> - To.Asttypes.Contravariant - | From.Asttypes.Invariant -> - To.Asttypes.Invariant - -and copy_value_description : - From.Parsetree.value_description -> - To.Parsetree.value_description - = - fun - { From.Parsetree.pval_name = pval_name; - From.Parsetree.pval_type = pval_type; - From.Parsetree.pval_prim = pval_prim; - From.Parsetree.pval_attributes = pval_attributes; - From.Parsetree.pval_loc = pval_loc } - -> - { - To.Parsetree.pval_name = - (copy_loc (fun x -> x) pval_name); - To.Parsetree.pval_type = - (copy_core_type pval_type); - To.Parsetree.pval_prim = - (List.map (fun x -> x) pval_prim); - To.Parsetree.pval_attributes = - (copy_attributes pval_attributes); - To.Parsetree.pval_loc = - (copy_location pval_loc) - } - -and copy_closed_flag : - From.Asttypes.closed_flag -> - To.Asttypes.closed_flag - = - function - | From.Asttypes.Closed -> To.Asttypes.Closed - | From.Asttypes.Open -> To.Asttypes.Open - -and copy_label : - From.Asttypes.label -> To.Asttypes.label = - fun x -> - x - -and copy_arg_label : - From.Asttypes.label -> To.Asttypes.arg_label = - fun x -> - if x <> "" then - if x.[0] = '?' then To.Asttypes.Optional (String.sub x 1 (String.length x - 1)) - else To.Asttypes.Labelled x - else - To.Asttypes.Nolabel - - - -and copy_rec_flag : - From.Asttypes.rec_flag -> To.Asttypes.rec_flag = - function - | From.Asttypes.Nonrecursive -> - To.Asttypes.Nonrecursive - | From.Asttypes.Recursive -> - To.Asttypes.Recursive - -and copy_constant : - From.Asttypes.constant -> To.Parsetree.constant = - function - | From.Asttypes.Const_int x0 -> - To.Parsetree.Pconst_integer (string_of_int x0, None) - | From.Asttypes.Const_char x0 -> - To.Parsetree.Pconst_char x0 - | From.Asttypes.Const_string (x0,x1) -> - To.Parsetree.Pconst_string - (x0, (copy_option (fun x -> x) x1)) - | From.Asttypes.Const_float x0 -> - To.Parsetree.Pconst_float (x0, None) - | From.Asttypes.Const_int32 x0 -> - To.Parsetree.Pconst_integer (Int32.to_string x0, Some 'l') - | From.Asttypes.Const_int64 x0 -> - To.Parsetree.Pconst_integer (Int64.to_string x0, Some 'L') - | From.Asttypes.Const_nativeint x0 -> - To.Parsetree.Pconst_integer (Nativeint.to_string x0, Some 'n') - -and copy_option : 'f0 'g0 . ('f0 -> 'g0) -> 'f0 option -> 'g0 option = - fun f0 -> function | None -> None | Some x0 -> Some (f0 x0) - -and copy_longident : - From.Longident.t -> To.Longident.t = - function - | From.Longident.Lident x0 -> - To.Longident.Lident x0 - | From.Longident.Ldot (x0,x1) -> - To.Longident.Ldot ((copy_longident x0), x1) - | From.Longident.Lapply (x0,x1) -> - To.Longident.Lapply ((copy_longident x0), (copy_longident x1)) - -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc - = - fun f0 -> - fun - { From.Asttypes.txt = txt; - From.Asttypes.loc = loc } - -> - { - To.Asttypes.txt = (f0 txt); - To.Asttypes.loc = (copy_location loc) - } - -and copy_location : - From.Location.t -> To.Location.t = - fun - { From.Location.loc_start = loc_start; - From.Location.loc_end = loc_end; - From.Location.loc_ghost = loc_ghost } - -> - { - To.Location.loc_start = (copy_Lexing_position loc_start); - To.Location.loc_end = (copy_Lexing_position loc_end); - To.Location.loc_ghost = (copy_bool loc_ghost) - } - -and copy_bool : bool -> bool = function | false -> false | true -> true - -and copy_Lexing_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum + (fun x -> + let (x0, x1, x2) = x in + (x0, (List.map copy_out_type x1), + (Option.map copy_out_type x2))) otyext_constructors); + Ast_403.Outcometree.otyext_private = (copy_private_flag otyext_private) } - -and type_declarations types = - let is_nonrec (attr,_) = attr.To.Location.txt = "nonrec" in - match List.map copy_type_declaration types with - | (x :: xs) - when List.exists is_nonrec x.To.Parsetree.ptype_attributes -> - let ptype_attributes = - List.filter (fun x -> not (is_nonrec x)) x.To.Parsetree.ptype_attributes - in - (To.Asttypes.Nonrecursive, - {x with To.Parsetree.ptype_attributes} :: xs) - | types -> (To.Asttypes.Recursive, types) - -let rec copy_out_phrase : - From.Outcometree.out_phrase -> To.Outcometree.out_phrase = +and copy_out_phrase : + Ast_402.Outcometree.out_phrase -> Ast_403.Outcometree.out_phrase = function - | From.Outcometree.Ophr_eval (x0,x1) -> - To.Outcometree.Ophr_eval - ((copy_out_value x0), - (copy_out_type x1)) - | From.Outcometree.Ophr_signature x0 -> - To.Outcometree.Ophr_signature + | Ast_402.Outcometree.Ophr_eval (x0, x1) -> + Ast_403.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1)) + | Ast_402.Outcometree.Ophr_signature x0 -> + Ast_403.Outcometree.Ophr_signature (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_sig_item x0), - (copy_option copy_out_value x1))) x0) - | From.Outcometree.Ophr_exception x0 -> - To.Outcometree.Ophr_exception - (let (x0,x1) = x0 in - ((copy_exn x0), (copy_out_value x1))) - -and copy_exn : exn -> exn = fun x -> x - + (fun x -> + let (x0, x1) = x in + ((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0) + | Ast_402.Outcometree.Ophr_exception x0 -> + Ast_403.Outcometree.Ophr_exception + (let (x0, x1) = x0 in (x0, (copy_out_value x1))) and copy_out_sig_item : - From.Outcometree.out_sig_item -> To.Outcometree.out_sig_item = + Ast_402.Outcometree.out_sig_item -> Ast_403.Outcometree.out_sig_item = function - | From.Outcometree.Osig_class (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class - ((copy_bool x0), x1, + | Ast_402.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> + Ast_403.Outcometree.Osig_class + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_class_type (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class_type - ((copy_bool x0), x1, + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_402.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> + Ast_403.Outcometree.Osig_class_type + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_typext (x0,x1) -> - To.Outcometree.Osig_typext - ((copy_out_extension_constructor x0), - (copy_out_ext_status x1)) - | From.Outcometree.Osig_modtype (x0,x1) -> - To.Outcometree.Osig_modtype - (x0, (copy_out_module_type x1)) - | From.Outcometree.Osig_module (x0,x1,x2) -> - To.Outcometree.Osig_module - (x0, (copy_out_module_type x1), - (copy_out_rec_status x2)) - | From.Outcometree.Osig_type (x0,x1) -> - To.Outcometree.Osig_type - ((copy_out_type_decl x0), - (copy_out_rec_status x1)) - | From.Outcometree.Osig_value (x0,x1,x2) -> + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_402.Outcometree.Osig_typext (x0, x1) -> + Ast_403.Outcometree.Osig_typext + ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) + | Ast_402.Outcometree.Osig_modtype (x0, x1) -> + Ast_403.Outcometree.Osig_modtype (x0, (copy_out_module_type x1)) + | Ast_402.Outcometree.Osig_module (x0, x1, x2) -> + Ast_403.Outcometree.Osig_module + (x0, (copy_out_module_type x1), (copy_out_rec_status x2)) + | Ast_402.Outcometree.Osig_type (x0, x1) -> + Ast_403.Outcometree.Osig_type + ((copy_out_type_decl x0), (copy_out_rec_status x1)) + | Ast_402.Outcometree.Osig_value (x0, x1, x2) -> To.Outcometree.Osig_value { To.Outcometree. oval_name = x0; oval_type = copy_out_type x1; oval_prims = List.map (fun x -> x) x2; oval_attributes = [] } - and copy_out_type_decl : - From.Outcometree.out_type_decl -> To.Outcometree.out_type_decl = + Ast_402.Outcometree.out_type_decl -> Ast_403.Outcometree.out_type_decl = fun - { From.Outcometree.otype_name = otype_name; - From.Outcometree.otype_params = otype_params; - From.Outcometree.otype_type = otype_type; - From.Outcometree.otype_private = otype_private; - From.Outcometree.otype_cstrs = otype_cstrs } - -> + { Ast_402.Outcometree.otype_name = otype_name; + Ast_402.Outcometree.otype_params = otype_params; + Ast_402.Outcometree.otype_type = otype_type; + Ast_402.Outcometree.otype_private = otype_private; + Ast_402.Outcometree.otype_cstrs = otype_cstrs } + -> { - To.Outcometree.otype_name = otype_name; - To.Outcometree.otype_params = + Ast_403.Outcometree.otype_name = otype_name; + Ast_403.Outcometree.otype_params = (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) otype_params); - To.Outcometree.otype_type = - (copy_out_type otype_type); - To.Outcometree.otype_private = - (copy_private_flag otype_private); - To.Outcometree.otype_cstrs = + Ast_403.Outcometree.otype_type = (copy_out_type otype_type); + Ast_403.Outcometree.otype_private = (copy_private_flag otype_private); + Ast_403.Outcometree.otype_cstrs = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_type x0), - (copy_out_type x1))) otype_cstrs); + (fun x -> + let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1))) + otype_cstrs); To.Outcometree.otype_immediate = false; } - and copy_out_module_type : - From.Outcometree.out_module_type -> To.Outcometree.out_module_type - = - function - | From.Outcometree.Omty_abstract -> To.Outcometree.Omty_abstract - | From.Outcometree.Omty_functor (x0,x1,x2) -> - To.Outcometree.Omty_functor - (x0, (copy_option copy_out_module_type x1), - (copy_out_module_type x2)) - | From.Outcometree.Omty_ident x0 -> - To.Outcometree.Omty_ident (copy_out_ident x0) - | From.Outcometree.Omty_signature x0 -> - To.Outcometree.Omty_signature - (List.map copy_out_sig_item x0) - | From.Outcometree.Omty_alias x0 -> - To.Outcometree.Omty_alias (copy_out_ident x0) - + Ast_402.Outcometree.out_module_type -> Ast_403.Outcometree.out_module_type + = + function + | Ast_402.Outcometree.Omty_abstract -> Ast_403.Outcometree.Omty_abstract + | Ast_402.Outcometree.Omty_functor (x0, x1, x2) -> + Ast_403.Outcometree.Omty_functor + (x0, (Option.map copy_out_module_type x1), (copy_out_module_type x2)) + | Ast_402.Outcometree.Omty_ident x0 -> + Ast_403.Outcometree.Omty_ident (copy_out_ident x0) + | Ast_402.Outcometree.Omty_signature x0 -> + Ast_403.Outcometree.Omty_signature (List.map copy_out_sig_item x0) + | Ast_402.Outcometree.Omty_alias x0 -> + Ast_403.Outcometree.Omty_alias (copy_out_ident x0) and copy_out_ext_status : - From.Outcometree.out_ext_status -> To.Outcometree.out_ext_status = + Ast_402.Outcometree.out_ext_status -> Ast_403.Outcometree.out_ext_status = function - | From.Outcometree.Oext_first -> To.Outcometree.Oext_first - | From.Outcometree.Oext_next -> To.Outcometree.Oext_next - | From.Outcometree.Oext_exception -> To.Outcometree.Oext_exception - + | Ast_402.Outcometree.Oext_first -> Ast_403.Outcometree.Oext_first + | Ast_402.Outcometree.Oext_next -> Ast_403.Outcometree.Oext_next + | Ast_402.Outcometree.Oext_exception -> Ast_403.Outcometree.Oext_exception and copy_out_extension_constructor : - From.Outcometree.out_extension_constructor -> - To.Outcometree.out_extension_constructor + Ast_402.Outcometree.out_extension_constructor -> + Ast_403.Outcometree.out_extension_constructor = fun - { From.Outcometree.oext_name = oext_name; - From.Outcometree.oext_type_name = oext_type_name; - From.Outcometree.oext_type_params = oext_type_params; - From.Outcometree.oext_args = oext_args; - From.Outcometree.oext_ret_type = oext_ret_type; - From.Outcometree.oext_private = oext_private } - -> + { Ast_402.Outcometree.oext_name = oext_name; + Ast_402.Outcometree.oext_type_name = oext_type_name; + Ast_402.Outcometree.oext_type_params = oext_type_params; + Ast_402.Outcometree.oext_args = oext_args; + Ast_402.Outcometree.oext_ret_type = oext_ret_type; + Ast_402.Outcometree.oext_private = oext_private } + -> { - To.Outcometree.oext_name = oext_name; - To.Outcometree.oext_type_name = oext_type_name; - To.Outcometree.oext_type_params = - (List.map (fun x -> x) oext_type_params); - To.Outcometree.oext_args = - (List.map copy_out_type oext_args); - To.Outcometree.oext_ret_type = - (copy_option copy_out_type oext_ret_type); - To.Outcometree.oext_private = - (copy_private_flag oext_private) + Ast_403.Outcometree.oext_name = oext_name; + Ast_403.Outcometree.oext_type_name = oext_type_name; + Ast_403.Outcometree.oext_type_params = + (List.map (fun x -> x) oext_type_params); + Ast_403.Outcometree.oext_args = (List.map copy_out_type oext_args); + Ast_403.Outcometree.oext_ret_type = + (Option.map copy_out_type oext_ret_type); + Ast_403.Outcometree.oext_private = (copy_private_flag oext_private) } - +and copy_private_flag : + Ast_402.Asttypes.private_flag -> Ast_403.Asttypes.private_flag = + function + | Ast_402.Asttypes.Private -> Ast_403.Asttypes.Private + | Ast_402.Asttypes.Public -> Ast_403.Asttypes.Public and copy_out_rec_status : - From.Outcometree.out_rec_status -> To.Outcometree.out_rec_status = + Ast_402.Outcometree.out_rec_status -> Ast_403.Outcometree.out_rec_status = function - | From.Outcometree.Orec_not -> To.Outcometree.Orec_not - | From.Outcometree.Orec_first -> To.Outcometree.Orec_first - | From.Outcometree.Orec_next -> To.Outcometree.Orec_next - + | Ast_402.Outcometree.Orec_not -> Ast_403.Outcometree.Orec_not + | Ast_402.Outcometree.Orec_first -> Ast_403.Outcometree.Orec_first + | Ast_402.Outcometree.Orec_next -> Ast_403.Outcometree.Orec_next and copy_out_class_type : - From.Outcometree.out_class_type -> To.Outcometree.out_class_type = - function - | From.Outcometree.Octy_constr (x0,x1) -> - To.Outcometree.Octy_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Octy_arrow (x0,x1,x2) -> - To.Outcometree.Octy_arrow - (x0, (copy_out_type x1), - (copy_out_class_type x2)) - | From.Outcometree.Octy_signature (x0,x1) -> - To.Outcometree.Octy_signature - ((copy_option copy_out_type x0), + Ast_402.Outcometree.out_class_type -> Ast_403.Outcometree.out_class_type = + function + | Ast_402.Outcometree.Octy_constr (x0, x1) -> + Ast_403.Outcometree.Octy_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_402.Outcometree.Octy_arrow (x0, x1, x2) -> + Ast_403.Outcometree.Octy_arrow + (x0, (copy_out_type x1), (copy_out_class_type x2)) + | Ast_402.Outcometree.Octy_signature (x0, x1) -> + Ast_403.Outcometree.Octy_signature + ((Option.map copy_out_type x0), (List.map copy_out_class_sig_item x1)) - and copy_out_class_sig_item : - From.Outcometree.out_class_sig_item -> - To.Outcometree.out_class_sig_item + Ast_402.Outcometree.out_class_sig_item -> + Ast_403.Outcometree.out_class_sig_item = function - | From.Outcometree.Ocsg_constraint (x0,x1) -> - To.Outcometree.Ocsg_constraint - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Ocsg_method (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_method - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - | From.Outcometree.Ocsg_value (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_value - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - + | Ast_402.Outcometree.Ocsg_constraint (x0, x1) -> + Ast_403.Outcometree.Ocsg_constraint + ((copy_out_type x0), (copy_out_type x1)) + | Ast_402.Outcometree.Ocsg_method (x0, x1, x2, x3) -> + Ast_403.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3)) + | Ast_402.Outcometree.Ocsg_value (x0, x1, x2, x3) -> + Ast_403.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3)) and copy_out_type : - From.Outcometree.out_type -> To.Outcometree.out_type = - function - | From.Outcometree.Otyp_abstract -> To.Outcometree.Otyp_abstract - | From.Outcometree.Otyp_open -> To.Outcometree.Otyp_open - | From.Outcometree.Otyp_alias (x0,x1) -> - To.Outcometree.Otyp_alias - ((copy_out_type x0), x1) - | From.Outcometree.Otyp_arrow (x0,x1,x2) -> - To.Outcometree.Otyp_arrow - (x0, (copy_out_type x1), - (copy_out_type x2)) - | From.Outcometree.Otyp_class (x0,x1,x2) -> - To.Outcometree.Otyp_class - ((copy_bool x0), (copy_out_ident x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_constr (x0,x1) -> - To.Outcometree.Otyp_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Otyp_manifest (x0,x1) -> - To.Outcometree.Otyp_manifest - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Otyp_object (x0,x1) -> - To.Outcometree.Otyp_object - ((List.map - (fun x -> - let (x0,x1) = x in - (x0, (copy_out_type x1))) x0), - (copy_option copy_bool x1)) - | From.Outcometree.Otyp_record x0 -> - To.Outcometree.Otyp_record + Ast_402.Outcometree.out_type -> Ast_403.Outcometree.out_type = + function + | Ast_402.Outcometree.Otyp_abstract -> Ast_403.Outcometree.Otyp_abstract + | Ast_402.Outcometree.Otyp_open -> Ast_403.Outcometree.Otyp_open + | Ast_402.Outcometree.Otyp_alias (x0, x1) -> + Ast_403.Outcometree.Otyp_alias ((copy_out_type x0), x1) + | Ast_402.Outcometree.Otyp_arrow (x0, x1, x2) -> + Ast_403.Outcometree.Otyp_arrow + (x0, (copy_out_type x1), (copy_out_type x2)) + | Ast_402.Outcometree.Otyp_class (x0, x1, x2) -> + Ast_403.Outcometree.Otyp_class + (x0, (copy_out_ident x1), (List.map copy_out_type x2)) + | Ast_402.Outcometree.Otyp_constr (x0, x1) -> + Ast_403.Outcometree.Otyp_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_402.Outcometree.Otyp_manifest (x0, x1) -> + Ast_403.Outcometree.Otyp_manifest + ((copy_out_type x0), (copy_out_type x1)) + | Ast_402.Outcometree.Otyp_object (x0, x1) -> + Ast_403.Outcometree.Otyp_object + ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0), + (Option.map (fun x -> x) x1)) + | Ast_402.Outcometree.Otyp_record x0 -> + Ast_403.Outcometree.Otyp_record (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), (copy_out_type x2))) - x0) - | From.Outcometree.Otyp_stuff x0 -> To.Outcometree.Otyp_stuff x0 - | From.Outcometree.Otyp_sum x0 -> - To.Outcometree.Otyp_sum + (fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0) + | Ast_402.Outcometree.Otyp_stuff x0 -> Ast_403.Outcometree.Otyp_stuff x0 + | Ast_402.Outcometree.Otyp_sum x0 -> + Ast_403.Outcometree.Otyp_sum (List.map - (fun x -> - let (x0,x1,x2) = x in + (fun x -> + let (x0, x1, x2) = x in (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) x0) - | From.Outcometree.Otyp_tuple x0 -> - To.Outcometree.Otyp_tuple - (List.map copy_out_type x0) - | From.Outcometree.Otyp_var (x0,x1) -> - To.Outcometree.Otyp_var ((copy_bool x0), x1) - | From.Outcometree.Otyp_variant (x0,x1,x2,x3) -> - To.Outcometree.Otyp_variant - ((copy_bool x0), (copy_out_variant x1), - (copy_bool x2), - (copy_option (fun x -> List.map (fun x -> x) x) x3)) - | From.Outcometree.Otyp_poly (x0,x1) -> - To.Outcometree.Otyp_poly - ((List.map (fun x -> x) x0), (copy_out_type x1)) - | From.Outcometree.Otyp_module (x0,x1,x2) -> - To.Outcometree.Otyp_module - (x0, (List.map (fun x -> x) x1), - (List.map copy_out_type x2)) - + (Option.map copy_out_type x2))) x0) + | Ast_402.Outcometree.Otyp_tuple x0 -> + Ast_403.Outcometree.Otyp_tuple (List.map copy_out_type x0) + | Ast_402.Outcometree.Otyp_var (x0, x1) -> + Ast_403.Outcometree.Otyp_var (x0, x1) + | Ast_402.Outcometree.Otyp_variant (x0, x1, x2, x3) -> + Ast_403.Outcometree.Otyp_variant + (x0, (copy_out_variant x1), x2, + (Option.map (fun x -> List.map (fun x -> x) x) x3)) + | Ast_402.Outcometree.Otyp_poly (x0, x1) -> + Ast_403.Outcometree.Otyp_poly + ((List.map (fun x -> x) x0), (copy_out_type x1)) + | Ast_402.Outcometree.Otyp_module (x0, x1, x2) -> + Ast_403.Outcometree.Otyp_module + (x0, (List.map (fun x -> x) x1), (List.map copy_out_type x2)) and copy_out_variant : - From.Outcometree.out_variant -> To.Outcometree.out_variant = + Ast_402.Outcometree.out_variant -> Ast_403.Outcometree.out_variant = function - | From.Outcometree.Ovar_fields x0 -> - To.Outcometree.Ovar_fields + | Ast_402.Outcometree.Ovar_fields x0 -> + Ast_403.Outcometree.Ovar_fields (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), - (List.map copy_out_type x2))) x0) - | From.Outcometree.Ovar_name (x0,x1) -> - To.Outcometree.Ovar_name - ((copy_out_ident x0), - (List.map copy_out_type x1)) - + (fun x -> + let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2))) + x0) + | Ast_402.Outcometree.Ovar_name (x0, x1) -> + Ast_403.Outcometree.Ovar_name + ((copy_out_ident x0), (List.map copy_out_type x1)) and copy_out_value : - From.Outcometree.out_value -> To.Outcometree.out_value = - function - | From.Outcometree.Oval_array x0 -> - To.Outcometree.Oval_array - (List.map copy_out_value x0) - | From.Outcometree.Oval_char x0 -> To.Outcometree.Oval_char x0 - | From.Outcometree.Oval_constr (x0,x1) -> - To.Outcometree.Oval_constr - ((copy_out_ident x0), - (List.map copy_out_value x1)) - | From.Outcometree.Oval_ellipsis -> To.Outcometree.Oval_ellipsis - | From.Outcometree.Oval_float x0 -> - To.Outcometree.Oval_float (copy_float x0) - | From.Outcometree.Oval_int x0 -> To.Outcometree.Oval_int x0 - | From.Outcometree.Oval_int32 x0 -> To.Outcometree.Oval_int32 x0 - | From.Outcometree.Oval_int64 x0 -> To.Outcometree.Oval_int64 x0 - | From.Outcometree.Oval_nativeint x0 -> - To.Outcometree.Oval_nativeint x0 - | From.Outcometree.Oval_list x0 -> - To.Outcometree.Oval_list - (List.map copy_out_value x0) - | From.Outcometree.Oval_printer x0 -> - To.Outcometree.Oval_printer x0 - | From.Outcometree.Oval_record x0 -> - To.Outcometree.Oval_record + Ast_402.Outcometree.out_value -> Ast_403.Outcometree.out_value = + function + | Ast_402.Outcometree.Oval_array x0 -> + Ast_403.Outcometree.Oval_array (List.map copy_out_value x0) + | Ast_402.Outcometree.Oval_char x0 -> Ast_403.Outcometree.Oval_char x0 + | Ast_402.Outcometree.Oval_constr (x0, x1) -> + Ast_403.Outcometree.Oval_constr + ((copy_out_ident x0), (List.map copy_out_value x1)) + | Ast_402.Outcometree.Oval_ellipsis -> Ast_403.Outcometree.Oval_ellipsis + | Ast_402.Outcometree.Oval_float x0 -> Ast_403.Outcometree.Oval_float x0 + | Ast_402.Outcometree.Oval_int x0 -> Ast_403.Outcometree.Oval_int x0 + | Ast_402.Outcometree.Oval_int32 x0 -> Ast_403.Outcometree.Oval_int32 x0 + | Ast_402.Outcometree.Oval_int64 x0 -> Ast_403.Outcometree.Oval_int64 x0 + | Ast_402.Outcometree.Oval_nativeint x0 -> + Ast_403.Outcometree.Oval_nativeint x0 + | Ast_402.Outcometree.Oval_list x0 -> + Ast_403.Outcometree.Oval_list (List.map copy_out_value x0) + | Ast_402.Outcometree.Oval_printer x0 -> + Ast_403.Outcometree.Oval_printer x0 + | Ast_402.Outcometree.Oval_record x0 -> + Ast_403.Outcometree.Oval_record (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_ident x0), - (copy_out_value x1))) x0) - | From.Outcometree.Oval_string x0 -> To.Outcometree.Oval_string x0 - | From.Outcometree.Oval_stuff x0 -> To.Outcometree.Oval_stuff x0 - | From.Outcometree.Oval_tuple x0 -> - To.Outcometree.Oval_tuple - (List.map copy_out_value x0) - | From.Outcometree.Oval_variant (x0,x1) -> - To.Outcometree.Oval_variant - (x0, (copy_option copy_out_value x1)) - -and copy_float : float -> float = fun x -> x - + (fun x -> + let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1))) + x0) + | Ast_402.Outcometree.Oval_string x0 -> Ast_403.Outcometree.Oval_string x0 + | Ast_402.Outcometree.Oval_stuff x0 -> Ast_403.Outcometree.Oval_stuff x0 + | Ast_402.Outcometree.Oval_tuple x0 -> + Ast_403.Outcometree.Oval_tuple (List.map copy_out_value x0) + | Ast_402.Outcometree.Oval_variant (x0, x1) -> + Ast_403.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1)) and copy_out_ident : - From.Outcometree.out_ident -> To.Outcometree.out_ident = - function - | From.Outcometree.Oide_apply (x0,x1) -> - To.Outcometree.Oide_apply - ((copy_out_ident x0), - (copy_out_ident x1)) - | From.Outcometree.Oide_dot (x0,x1) -> - To.Outcometree.Oide_dot - ((copy_out_ident x0), x1) - | From.Outcometree.Oide_ident x0 -> To.Outcometree.Oide_ident x0 - -let rec copy_toplevel_phrase : - From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = - function - | From.Parsetree.Ptop_def x0 -> - To.Parsetree.Ptop_def (copy_structure x0) - | From.Parsetree.Ptop_dir (x0,x1) -> - To.Parsetree.Ptop_dir - (x0, (copy_directive_argument x1)) - -and copy_directive_argument : - From.Parsetree.directive_argument -> To.Parsetree.directive_argument = - function - | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none - | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 - | From.Parsetree.Pdir_int x0 -> To.Parsetree.Pdir_int (string_of_int x0, None) - | From.Parsetree.Pdir_ident x0 -> To.Parsetree.Pdir_ident (copy_longident x0) - | From.Parsetree.Pdir_bool x0 -> To.Parsetree.Pdir_bool (copy_bool x0) - -let copy_out_type_extension : - From.Outcometree.out_type_extension -> To.Outcometree.out_type_extension = - fun - { From.Outcometree.otyext_name = otyext_name; - From.Outcometree.otyext_params = otyext_params; - From.Outcometree.otyext_constructors = otyext_constructors; - From.Outcometree.otyext_private = otyext_private } - -> - { - To.Outcometree.otyext_name = otyext_name; - To.Outcometree.otyext_params = - (List.map (fun x -> x) otyext_params); - To.Outcometree.otyext_constructors = - (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) - otyext_constructors); - To.Outcometree.otyext_private = - (copy_private_flag otyext_private) - } - -let copy_cases x = List.map copy_case x -let copy_pat = copy_pattern -let copy_expr = copy_expression -let copy_typ = copy_core_type + Ast_402.Outcometree.out_ident -> Ast_403.Outcometree.out_ident = + function + | Ast_402.Outcometree.Oide_apply (x0, x1) -> + Ast_403.Outcometree.Oide_apply + ((copy_out_ident x0), (copy_out_ident x1)) + | Ast_402.Outcometree.Oide_dot (x0, x1) -> + Ast_403.Outcometree.Oide_dot ((copy_out_ident x0), x1) + | Ast_402.Outcometree.Oide_ident x0 -> Ast_403.Outcometree.Oide_ident x0 diff --git a/src/vendored-omp/src/migrate_parsetree_403_402.ml b/src/vendored-omp/src/migrate_parsetree_403_402.ml index d24b9674a..076613439 100644 --- a/src/vendored-omp/src/migrate_parsetree_403_402.ml +++ b/src/vendored-omp/src/migrate_parsetree_403_402.ml @@ -15,116 +15,3 @@ include Migrate_parsetree_403_402_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - (*$*) - payload - } as mapper) -> - let module R = Migrate_parsetree_402_403_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - (*$*) - payload = (fun _ x -> copy_payload Location.none (payload mapper (R.copy_payload x))) - } diff --git a/src/vendored-omp/src/migrate_parsetree_403_402_migrate.ml b/src/vendored-omp/src/migrate_parsetree_403_402_migrate.ml index efdd06aa0..36d8b61cb 100644 --- a/src/vendored-omp/src/migrate_parsetree_403_402_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_403_402_migrate.ml @@ -1,1608 +1,72 @@ -(**************************************************************************) -(* *) -(* OCaml Migrate Parsetree *) -(* *) -(* Frédéric Bour *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2017 Institut National de Recherche en Informatique et *) -(* en Automatique (INRIA). *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -module Def = Migrate_parsetree_def +open Stdlib0 module From = Ast_403 module To = Ast_402 - -let inject_predef_option label d = - let open To in - let open Parsetree in - match label with - | From.Asttypes.Optional _ -> - let loc = {d.ptyp_loc with Location.loc_ghost = true} in - let txt = Longident.Ldot (Longident.Lident "*predef*", "option") in - let ident = {Location. txt; loc} in - { ptyp_desc = Ptyp_constr(ident,[d]); ptyp_loc = loc; ptyp_attributes = []} - | _ -> d - -let from_loc {From.Location. txt = _; loc} = loc - -let migration_error location feature = - raise (Def.Migration_error (feature, location)) - -let rec copy_expression : - From.Parsetree.expression -> - To.Parsetree.expression +let rec copy_out_type_extension : + Ast_403.Outcometree.out_type_extension -> + Ast_402.Outcometree.out_type_extension = fun - { From.Parsetree.pexp_desc = pexp_desc; - From.Parsetree.pexp_loc = pexp_loc; - From.Parsetree.pexp_attributes = pexp_attributes } - -> + { Ast_403.Outcometree.otyext_name = otyext_name; + Ast_403.Outcometree.otyext_params = otyext_params; + Ast_403.Outcometree.otyext_constructors = otyext_constructors; + Ast_403.Outcometree.otyext_private = otyext_private } + -> { - To.Parsetree.pexp_desc = - (copy_expression_desc pexp_loc pexp_desc); - To.Parsetree.pexp_loc = - (copy_location pexp_loc); - To.Parsetree.pexp_attributes = - (copy_attributes pexp_attributes) - } - -and copy_expression_desc loc : - From.Parsetree.expression_desc -> - To.Parsetree.expression_desc - = - function - | From.Parsetree.Pexp_ident x0 -> - To.Parsetree.Pexp_ident - (copy_loc copy_longident - x0) - | From.Parsetree.Pexp_constant x0 -> - To.Parsetree.Pexp_constant - (copy_constant loc x0) - | From.Parsetree.Pexp_let (x0,x1,x2) -> - To.Parsetree.Pexp_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_expression x2)) - | From.Parsetree.Pexp_function x0 -> - To.Parsetree.Pexp_function - (List.map copy_case x0) - | From.Parsetree.Pexp_fun (x0,x1,x2,x3) -> - To.Parsetree.Pexp_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_expression x3)) - | From.Parsetree.Pexp_apply (x0,x1) -> - To.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pexp_match (x0,x1) -> - To.Parsetree.Pexp_match - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_try (x0,x1) -> - To.Parsetree.Pexp_try - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_tuple x0 -> - To.Parsetree.Pexp_tuple - (List.map copy_expression x0) - | From.Parsetree.Pexp_construct (x0,x1) -> - To.Parsetree.Pexp_construct - ((copy_loc - copy_longident x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_variant (x0,x1) -> - To.Parsetree.Pexp_variant - ((copy_label x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_record (x0,x1) -> - To.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc - copy_longident x0), - (copy_expression x1))) x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_field (x0,x1) -> - To.Parsetree.Pexp_field - ((copy_expression x0), - (copy_loc - copy_longident x1)) - | From.Parsetree.Pexp_setfield (x0,x1,x2) -> - To.Parsetree.Pexp_setfield - ((copy_expression x0), - (copy_loc - copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_array x0 -> - To.Parsetree.Pexp_array - (List.map copy_expression x0) - | From.Parsetree.Pexp_ifthenelse (x0,x1,x2) -> - To.Parsetree.Pexp_ifthenelse - ((copy_expression x0), - (copy_expression x1), - (copy_option copy_expression x2)) - | From.Parsetree.Pexp_sequence (x0,x1) -> - To.Parsetree.Pexp_sequence - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_while (x0,x1) -> - To.Parsetree.Pexp_while - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_for (x0,x1,x2,x3,x4) -> - To.Parsetree.Pexp_for - ((copy_pattern x0), - (copy_expression x1), - (copy_expression x2), - (copy_direction_flag x3), - (copy_expression x4)) - | From.Parsetree.Pexp_constraint (x0,x1) -> - To.Parsetree.Pexp_constraint - ((copy_expression x0), - (copy_core_type x1)) - | From.Parsetree.Pexp_coerce (x0,x1,x2) -> - To.Parsetree.Pexp_coerce - ((copy_expression x0), - (copy_option copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Pexp_send (x0,x1) -> - To.Parsetree.Pexp_send - ((copy_expression x0), x1) - | From.Parsetree.Pexp_new x0 -> - To.Parsetree.Pexp_new - (copy_loc copy_longident - x0) - | From.Parsetree.Pexp_setinstvar (x0,x1) -> - To.Parsetree.Pexp_setinstvar - ((copy_loc (fun x -> x) x0), - (copy_expression x1)) - | From.Parsetree.Pexp_override x0 -> - To.Parsetree.Pexp_override + Ast_402.Outcometree.otyext_name = otyext_name; + Ast_402.Outcometree.otyext_params = + (List.map (fun x -> x) otyext_params); + Ast_402.Outcometree.otyext_constructors = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_expression x1))) x0) - | From.Parsetree.Pexp_letmodule (x0,x1,x2) -> - To.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> x) x0), - (copy_module_expr x1), - (copy_expression x2)) - | From.Parsetree.Pexp_assert x0 -> - To.Parsetree.Pexp_assert - (copy_expression x0) - | From.Parsetree.Pexp_lazy x0 -> - To.Parsetree.Pexp_lazy - (copy_expression x0) - | From.Parsetree.Pexp_poly (x0,x1) -> - To.Parsetree.Pexp_poly - ((copy_expression x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pexp_object x0 -> - To.Parsetree.Pexp_object - (copy_class_structure x0) - | From.Parsetree.Pexp_newtype (x0,x1) -> - To.Parsetree.Pexp_newtype - (x0, (copy_expression x1)) - | From.Parsetree.Pexp_pack x0 -> - To.Parsetree.Pexp_pack - (copy_module_expr x0) - | From.Parsetree.Pexp_open (x0,x1,x2) -> - To.Parsetree.Pexp_open - ((copy_override_flag x0), - (copy_loc - copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_extension x0 -> - To.Parsetree.Pexp_extension - (copy_extension x0) - | From.Parsetree.Pexp_unreachable -> - migration_error loc Def.Pexp_unreachable - -and copy_direction_flag : - From.Asttypes.direction_flag -> - To.Asttypes.direction_flag - = - function - | From.Asttypes.Upto -> To.Asttypes.Upto - | From.Asttypes.Downto -> To.Asttypes.Downto - -and copy_case : - From.Parsetree.case -> To.Parsetree.case = - fun - { From.Parsetree.pc_lhs = pc_lhs; - From.Parsetree.pc_guard = pc_guard; - From.Parsetree.pc_rhs = pc_rhs } - -> - { - To.Parsetree.pc_lhs = - (copy_pattern pc_lhs); - To.Parsetree.pc_guard = - (copy_option copy_expression pc_guard); - To.Parsetree.pc_rhs = - (copy_expression pc_rhs) - } - -and copy_value_binding : - From.Parsetree.value_binding -> - To.Parsetree.value_binding - = - fun - { From.Parsetree.pvb_pat = pvb_pat; - From.Parsetree.pvb_expr = pvb_expr; - From.Parsetree.pvb_attributes = pvb_attributes; - From.Parsetree.pvb_loc = pvb_loc } - -> - { - To.Parsetree.pvb_pat = - (copy_pattern pvb_pat); - To.Parsetree.pvb_expr = - (copy_expression pvb_expr); - To.Parsetree.pvb_attributes = - (copy_attributes pvb_attributes); - To.Parsetree.pvb_loc = - (copy_location pvb_loc) - } - -and copy_pattern : - From.Parsetree.pattern -> To.Parsetree.pattern = - fun - { From.Parsetree.ppat_desc = ppat_desc; - From.Parsetree.ppat_loc = ppat_loc; - From.Parsetree.ppat_attributes = ppat_attributes } - -> - { - To.Parsetree.ppat_desc = - (copy_pattern_desc ppat_loc ppat_desc); - To.Parsetree.ppat_loc = - (copy_location ppat_loc); - To.Parsetree.ppat_attributes = - (copy_attributes ppat_attributes) - } - -and copy_pattern_desc loc : - From.Parsetree.pattern_desc -> - To.Parsetree.pattern_desc - = - function - | From.Parsetree.Ppat_any -> - To.Parsetree.Ppat_any - | From.Parsetree.Ppat_var x0 -> - To.Parsetree.Ppat_var - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_alias (x0,x1) -> - To.Parsetree.Ppat_alias - ((copy_pattern x0), - (copy_loc (fun x -> x) x1)) - | From.Parsetree.Ppat_constant x0 -> - To.Parsetree.Ppat_constant - (copy_constant loc x0) - | From.Parsetree.Ppat_interval (x0,x1) -> - To.Parsetree.Ppat_interval - ((copy_constant loc x0), - (copy_constant loc x1)) - | From.Parsetree.Ppat_tuple x0 -> - To.Parsetree.Ppat_tuple - (List.map copy_pattern x0) - | From.Parsetree.Ppat_construct (x0,x1) -> - To.Parsetree.Ppat_construct - ((copy_loc - copy_longident x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_variant (x0,x1) -> - To.Parsetree.Ppat_variant - ((copy_label x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_record (x0,x1) -> - To.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc - copy_longident x0), - (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ppat_array x0 -> - To.Parsetree.Ppat_array - (List.map copy_pattern x0) - | From.Parsetree.Ppat_or (x0,x1) -> - To.Parsetree.Ppat_or - ((copy_pattern x0), - (copy_pattern x1)) - | From.Parsetree.Ppat_constraint (x0,x1) -> - To.Parsetree.Ppat_constraint - ((copy_pattern x0), - (copy_core_type x1)) - | From.Parsetree.Ppat_type x0 -> - To.Parsetree.Ppat_type - (copy_loc copy_longident - x0) - | From.Parsetree.Ppat_lazy x0 -> - To.Parsetree.Ppat_lazy - (copy_pattern x0) - | From.Parsetree.Ppat_unpack x0 -> - To.Parsetree.Ppat_unpack - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_exception x0 -> - To.Parsetree.Ppat_exception - (copy_pattern x0) - | From.Parsetree.Ppat_extension x0 -> - To.Parsetree.Ppat_extension - (copy_extension x0) - -and copy_core_type : - From.Parsetree.core_type -> - To.Parsetree.core_type - = - fun - { From.Parsetree.ptyp_desc = ptyp_desc; - From.Parsetree.ptyp_loc = ptyp_loc; - From.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - To.Parsetree.ptyp_desc = - (copy_core_type_desc ptyp_desc); - To.Parsetree.ptyp_loc = - (copy_location ptyp_loc); - To.Parsetree.ptyp_attributes = - (copy_attributes ptyp_attributes) - } - -and copy_core_type_desc : - From.Parsetree.core_type_desc -> - To.Parsetree.core_type_desc - = - function - | From.Parsetree.Ptyp_any -> - To.Parsetree.Ptyp_any - | From.Parsetree.Ptyp_var x0 -> - To.Parsetree.Ptyp_var x0 - | From.Parsetree.Ptyp_arrow (x0,x1,x2) -> - To.Parsetree.Ptyp_arrow - ((copy_arg_label x0), - inject_predef_option x0 (copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Ptyp_tuple x0 -> - To.Parsetree.Ptyp_tuple - (List.map copy_core_type x0) - | From.Parsetree.Ptyp_constr (x0,x1) -> - To.Parsetree.Ptyp_constr - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_object (x0,x1) -> - To.Parsetree.Ptyp_object - ((List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_attributes x1), - (copy_core_type x2))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ptyp_class (x0,x1) -> - To.Parsetree.Ptyp_class - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_alias (x0,x1) -> - To.Parsetree.Ptyp_alias - ((copy_core_type x0), x1) - | From.Parsetree.Ptyp_variant (x0,x1,x2) -> - To.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), - (copy_closed_flag x1), - (copy_option - (fun x -> List.map copy_label x) x2)) - | From.Parsetree.Ptyp_poly (x0,x1) -> - To.Parsetree.Ptyp_poly - ((List.map (fun x -> x) x0), - (copy_core_type x1)) - | From.Parsetree.Ptyp_package x0 -> - To.Parsetree.Ptyp_package - (copy_package_type x0) - | From.Parsetree.Ptyp_extension x0 -> - To.Parsetree.Ptyp_extension - (copy_extension x0) - -and copy_package_type : - From.Parsetree.package_type -> - To.Parsetree.package_type - = - fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc - copy_longident x0), - (copy_core_type x1))) x1)) - -and copy_row_field : - From.Parsetree.row_field -> - To.Parsetree.row_field - = - function - | From.Parsetree.Rtag (x0,x1,x2,x3) -> - To.Parsetree.Rtag - ((copy_label x0), - (copy_attributes x1), (copy_bool x2), - (List.map copy_core_type x3)) - | From.Parsetree.Rinherit x0 -> - To.Parsetree.Rinherit - (copy_core_type x0) - -and copy_attributes : - From.Parsetree.attributes -> - To.Parsetree.attributes - = fun x -> List.map copy_attribute x - -and copy_attribute : - From.Parsetree.attribute -> - To.Parsetree.attribute - = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload (from_loc x0) x1)) - -and copy_payload loc : - From.Parsetree.payload -> To.Parsetree.payload = - function - | From.Parsetree.PStr x0 -> - To.Parsetree.PStr - (copy_structure x0) - | From.Parsetree.PSig _x0 -> - migration_error loc Def.PSig - | From.Parsetree.PTyp x0 -> - To.Parsetree.PTyp - (copy_core_type x0) - | From.Parsetree.PPat (x0,x1) -> - To.Parsetree.PPat - ((copy_pattern x0), - (copy_option copy_expression x1)) - -and copy_structure : - From.Parsetree.structure -> - To.Parsetree.structure - = fun x -> List.map copy_structure_item x - -and copy_structure_item : - From.Parsetree.structure_item -> - To.Parsetree.structure_item - = - fun - { From.Parsetree.pstr_desc = pstr_desc; - From.Parsetree.pstr_loc = pstr_loc } - -> - { - To.Parsetree.pstr_desc = - (copy_structure_item_desc pstr_desc); - To.Parsetree.pstr_loc = - (copy_location pstr_loc) - } - -and copy_structure_item_desc : - From.Parsetree.structure_item_desc -> - To.Parsetree.structure_item_desc - = - function - | From.Parsetree.Pstr_eval (x0,x1) -> - To.Parsetree.Pstr_eval - ((copy_expression x0), - (copy_attributes x1)) - | From.Parsetree.Pstr_value (x0,x1) -> - To.Parsetree.Pstr_value - ((copy_rec_flag x0), - (List.map copy_value_binding x1)) - | From.Parsetree.Pstr_primitive x0 -> - To.Parsetree.Pstr_primitive - (copy_value_description x0) - | From.Parsetree.Pstr_type (x0,x1) -> - To.Parsetree.Pstr_type (type_declarations x0 x1) - | From.Parsetree.Pstr_typext x0 -> - To.Parsetree.Pstr_typext - (copy_type_extension x0) - | From.Parsetree.Pstr_exception x0 -> - To.Parsetree.Pstr_exception - (copy_extension_constructor x0) - | From.Parsetree.Pstr_module x0 -> - To.Parsetree.Pstr_module - (copy_module_binding x0) - | From.Parsetree.Pstr_recmodule x0 -> - To.Parsetree.Pstr_recmodule - (List.map copy_module_binding x0) - | From.Parsetree.Pstr_modtype x0 -> - To.Parsetree.Pstr_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Pstr_open x0 -> - To.Parsetree.Pstr_open - (copy_open_description x0) - | From.Parsetree.Pstr_class x0 -> - To.Parsetree.Pstr_class - (List.map copy_class_declaration x0) - | From.Parsetree.Pstr_class_type x0 -> - To.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Pstr_include x0 -> - To.Parsetree.Pstr_include - (copy_include_declaration x0) - | From.Parsetree.Pstr_attribute x0 -> - To.Parsetree.Pstr_attribute - (copy_attribute x0) - | From.Parsetree.Pstr_extension (x0,x1) -> - To.Parsetree.Pstr_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_include_declaration : - From.Parsetree.include_declaration -> - To.Parsetree.include_declaration - = - fun x -> - copy_include_infos - copy_module_expr x - -and copy_class_declaration : - From.Parsetree.class_declaration -> - To.Parsetree.class_declaration - = - fun x -> - copy_class_infos - copy_class_expr x - -and copy_class_expr : - From.Parsetree.class_expr -> - To.Parsetree.class_expr - = - fun - { From.Parsetree.pcl_desc = pcl_desc; - From.Parsetree.pcl_loc = pcl_loc; - From.Parsetree.pcl_attributes = pcl_attributes } - -> - { - To.Parsetree.pcl_desc = - (copy_class_expr_desc pcl_desc); - To.Parsetree.pcl_loc = - (copy_location pcl_loc); - To.Parsetree.pcl_attributes = - (copy_attributes pcl_attributes) - } - -and copy_class_expr_desc : - From.Parsetree.class_expr_desc -> - To.Parsetree.class_expr_desc - = - function - | From.Parsetree.Pcl_constr (x0,x1) -> - To.Parsetree.Pcl_constr - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcl_structure x0 -> - To.Parsetree.Pcl_structure - (copy_class_structure x0) - | From.Parsetree.Pcl_fun (x0,x1,x2,x3) -> - To.Parsetree.Pcl_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_class_expr x3)) - | From.Parsetree.Pcl_apply (x0,x1) -> - To.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pcl_let (x0,x1,x2) -> - To.Parsetree.Pcl_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_class_expr x2)) - | From.Parsetree.Pcl_constraint (x0,x1) -> - To.Parsetree.Pcl_constraint - ((copy_class_expr x0), - (copy_class_type x1)) - | From.Parsetree.Pcl_extension x0 -> - To.Parsetree.Pcl_extension - (copy_extension x0) - -and copy_class_structure : - From.Parsetree.class_structure -> - To.Parsetree.class_structure - = - fun - { From.Parsetree.pcstr_self = pcstr_self; - From.Parsetree.pcstr_fields = pcstr_fields } - -> - { - To.Parsetree.pcstr_self = - (copy_pattern pcstr_self); - To.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } - -and copy_class_field : - From.Parsetree.class_field -> - To.Parsetree.class_field - = - fun - { From.Parsetree.pcf_desc = pcf_desc; - From.Parsetree.pcf_loc = pcf_loc; - From.Parsetree.pcf_attributes = pcf_attributes } - -> - { - To.Parsetree.pcf_desc = - (copy_class_field_desc pcf_desc); - To.Parsetree.pcf_loc = - (copy_location pcf_loc); - To.Parsetree.pcf_attributes = - (copy_attributes pcf_attributes) - } - -and copy_class_field_desc : - From.Parsetree.class_field_desc -> - To.Parsetree.class_field_desc - = - function - | From.Parsetree.Pcf_inherit (x0,x1,x2) -> - To.Parsetree.Pcf_inherit - ((copy_override_flag x0), - (copy_class_expr x1), - (copy_option (fun x -> x) x2)) - | From.Parsetree.Pcf_val x0 -> - To.Parsetree.Pcf_val - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_method x0 -> - To.Parsetree.Pcf_method - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_private_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_constraint x0 -> - To.Parsetree.Pcf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pcf_initializer x0 -> - To.Parsetree.Pcf_initializer - (copy_expression x0) - | From.Parsetree.Pcf_attribute x0 -> - To.Parsetree.Pcf_attribute - (copy_attribute x0) - | From.Parsetree.Pcf_extension x0 -> - To.Parsetree.Pcf_extension - (copy_extension x0) - -and copy_class_field_kind : - From.Parsetree.class_field_kind -> - To.Parsetree.class_field_kind - = - function - | From.Parsetree.Cfk_virtual x0 -> - To.Parsetree.Cfk_virtual - (copy_core_type x0) - | From.Parsetree.Cfk_concrete (x0,x1) -> - To.Parsetree.Cfk_concrete - ((copy_override_flag x0), - (copy_expression x1)) - -and copy_module_binding : - From.Parsetree.module_binding -> - To.Parsetree.module_binding - = - fun - { From.Parsetree.pmb_name = pmb_name; - From.Parsetree.pmb_expr = pmb_expr; - From.Parsetree.pmb_attributes = pmb_attributes; - From.Parsetree.pmb_loc = pmb_loc } - -> - { - To.Parsetree.pmb_name = - (copy_loc (fun x -> x) pmb_name); - To.Parsetree.pmb_expr = - (copy_module_expr pmb_expr); - To.Parsetree.pmb_attributes = - (copy_attributes pmb_attributes); - To.Parsetree.pmb_loc = - (copy_location pmb_loc) - } - -and copy_module_expr : - From.Parsetree.module_expr -> - To.Parsetree.module_expr - = - fun - { From.Parsetree.pmod_desc = pmod_desc; - From.Parsetree.pmod_loc = pmod_loc; - From.Parsetree.pmod_attributes = pmod_attributes } - -> - { - To.Parsetree.pmod_desc = - (copy_module_expr_desc pmod_desc); - To.Parsetree.pmod_loc = - (copy_location pmod_loc); - To.Parsetree.pmod_attributes = - (copy_attributes pmod_attributes) - } - -and copy_module_expr_desc : - From.Parsetree.module_expr_desc -> - To.Parsetree.module_expr_desc - = - function - | From.Parsetree.Pmod_ident x0 -> - To.Parsetree.Pmod_ident - (copy_loc copy_longident - x0) - | From.Parsetree.Pmod_structure x0 -> - To.Parsetree.Pmod_structure - (copy_structure x0) - | From.Parsetree.Pmod_functor (x0,x1,x2) -> - To.Parsetree.Pmod_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_expr x2)) - | From.Parsetree.Pmod_apply (x0,x1) -> - To.Parsetree.Pmod_apply - ((copy_module_expr x0), - (copy_module_expr x1)) - | From.Parsetree.Pmod_constraint (x0,x1) -> - To.Parsetree.Pmod_constraint - ((copy_module_expr x0), - (copy_module_type x1)) - | From.Parsetree.Pmod_unpack x0 -> - To.Parsetree.Pmod_unpack - (copy_expression x0) - | From.Parsetree.Pmod_extension x0 -> - To.Parsetree.Pmod_extension - (copy_extension x0) - -and copy_module_type : - From.Parsetree.module_type -> - To.Parsetree.module_type - = - fun - { From.Parsetree.pmty_desc = pmty_desc; - From.Parsetree.pmty_loc = pmty_loc; - From.Parsetree.pmty_attributes = pmty_attributes } - -> - { - To.Parsetree.pmty_desc = - (copy_module_type_desc pmty_desc); - To.Parsetree.pmty_loc = - (copy_location pmty_loc); - To.Parsetree.pmty_attributes = - (copy_attributes pmty_attributes) - } - -and copy_module_type_desc : - From.Parsetree.module_type_desc -> - To.Parsetree.module_type_desc - = - function - | From.Parsetree.Pmty_ident x0 -> - To.Parsetree.Pmty_ident - (copy_loc copy_longident - x0) - | From.Parsetree.Pmty_signature x0 -> - To.Parsetree.Pmty_signature - (copy_signature x0) - | From.Parsetree.Pmty_functor (x0,x1,x2) -> - To.Parsetree.Pmty_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_type x2)) - | From.Parsetree.Pmty_with (x0,x1) -> - To.Parsetree.Pmty_with - ((copy_module_type x0), - (List.map copy_with_constraint x1)) - | From.Parsetree.Pmty_typeof x0 -> - To.Parsetree.Pmty_typeof - (copy_module_expr x0) - | From.Parsetree.Pmty_extension x0 -> - To.Parsetree.Pmty_extension - (copy_extension x0) - | From.Parsetree.Pmty_alias x0 -> - To.Parsetree.Pmty_alias - (copy_loc copy_longident - x0) - -and copy_with_constraint : - From.Parsetree.with_constraint -> - To.Parsetree.with_constraint - = - function - | From.Parsetree.Pwith_type (x0,x1) -> - To.Parsetree.Pwith_type - ((copy_loc - copy_longident x0), - (copy_type_declaration x1)) - | From.Parsetree.Pwith_module (x0,x1) -> - To.Parsetree.Pwith_module - ((copy_loc - copy_longident x0), - (copy_loc - copy_longident x1)) - | From.Parsetree.Pwith_typesubst x0 -> - To.Parsetree.Pwith_typesubst - (copy_type_declaration x0) - | From.Parsetree.Pwith_modsubst (x0,x1) -> - To.Parsetree.Pwith_modsubst - ((copy_loc (fun x -> x) x0), - (copy_loc - copy_longident x1)) - -and copy_signature : - From.Parsetree.signature -> - To.Parsetree.signature - = fun x -> List.map copy_signature_item x - -and copy_signature_item : - From.Parsetree.signature_item -> - To.Parsetree.signature_item - = - fun - { From.Parsetree.psig_desc = psig_desc; - From.Parsetree.psig_loc = psig_loc } - -> - { - To.Parsetree.psig_desc = - (copy_signature_item_desc psig_desc); - To.Parsetree.psig_loc = - (copy_location psig_loc) - } - -and copy_signature_item_desc : - From.Parsetree.signature_item_desc -> - To.Parsetree.signature_item_desc - = - function - | From.Parsetree.Psig_value x0 -> - To.Parsetree.Psig_value - (copy_value_description x0) - | From.Parsetree.Psig_type (x0,x1) -> - To.Parsetree.Psig_type (type_declarations x0 x1) - | From.Parsetree.Psig_typext x0 -> - To.Parsetree.Psig_typext - (copy_type_extension x0) - | From.Parsetree.Psig_exception x0 -> - To.Parsetree.Psig_exception - (copy_extension_constructor x0) - | From.Parsetree.Psig_module x0 -> - To.Parsetree.Psig_module - (copy_module_declaration x0) - | From.Parsetree.Psig_recmodule x0 -> - To.Parsetree.Psig_recmodule - (List.map copy_module_declaration x0) - | From.Parsetree.Psig_modtype x0 -> - To.Parsetree.Psig_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Psig_open x0 -> - To.Parsetree.Psig_open - (copy_open_description x0) - | From.Parsetree.Psig_include x0 -> - To.Parsetree.Psig_include - (copy_include_description x0) - | From.Parsetree.Psig_class x0 -> - To.Parsetree.Psig_class - (List.map copy_class_description x0) - | From.Parsetree.Psig_class_type x0 -> - To.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Psig_attribute x0 -> - To.Parsetree.Psig_attribute - (copy_attribute x0) - | From.Parsetree.Psig_extension (x0,x1) -> - To.Parsetree.Psig_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_class_type_declaration : - From.Parsetree.class_type_declaration -> - To.Parsetree.class_type_declaration - = - fun x -> - copy_class_infos - copy_class_type x - -and copy_class_description : - From.Parsetree.class_description -> - To.Parsetree.class_description - = - fun x -> - copy_class_infos - copy_class_type x - -and copy_class_type : - From.Parsetree.class_type -> - To.Parsetree.class_type - = - fun - { From.Parsetree.pcty_desc = pcty_desc; - From.Parsetree.pcty_loc = pcty_loc; - From.Parsetree.pcty_attributes = pcty_attributes } - -> - { - To.Parsetree.pcty_desc = - (copy_class_type_desc pcty_desc); - To.Parsetree.pcty_loc = - (copy_location pcty_loc); - To.Parsetree.pcty_attributes = - (copy_attributes pcty_attributes) - } - -and copy_class_type_desc : - From.Parsetree.class_type_desc -> - To.Parsetree.class_type_desc - = - function - | From.Parsetree.Pcty_constr (x0,x1) -> - To.Parsetree.Pcty_constr - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcty_signature x0 -> - To.Parsetree.Pcty_signature - (copy_class_signature x0) - | From.Parsetree.Pcty_arrow (x0,x1,x2) -> - To.Parsetree.Pcty_arrow - ((copy_arg_label x0), - inject_predef_option x0 (copy_core_type x1), - (copy_class_type x2)) - | From.Parsetree.Pcty_extension x0 -> - To.Parsetree.Pcty_extension - (copy_extension x0) - -and copy_class_signature : - From.Parsetree.class_signature -> - To.Parsetree.class_signature - = - fun - { From.Parsetree.pcsig_self = pcsig_self; - From.Parsetree.pcsig_fields = pcsig_fields } - -> - { - To.Parsetree.pcsig_self = - (copy_core_type pcsig_self); - To.Parsetree.pcsig_fields = - (List.map copy_class_type_field - pcsig_fields) - } - -and copy_class_type_field : - From.Parsetree.class_type_field -> - To.Parsetree.class_type_field - = - fun - { From.Parsetree.pctf_desc = pctf_desc; - From.Parsetree.pctf_loc = pctf_loc; - From.Parsetree.pctf_attributes = pctf_attributes } - -> - { - To.Parsetree.pctf_desc = - (copy_class_type_field_desc pctf_desc); - To.Parsetree.pctf_loc = - (copy_location pctf_loc); - To.Parsetree.pctf_attributes = - (copy_attributes pctf_attributes) - } - -and copy_class_type_field_desc : - From.Parsetree.class_type_field_desc -> - To.Parsetree.class_type_field_desc - = - function - | From.Parsetree.Pctf_inherit x0 -> - To.Parsetree.Pctf_inherit - (copy_class_type x0) - | From.Parsetree.Pctf_val x0 -> - To.Parsetree.Pctf_val - (let (x0,x1,x2,x3) = x0 in - (x0, (copy_mutable_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_method x0 -> - To.Parsetree.Pctf_method - (let (x0,x1,x2,x3) = x0 in - (x0, (copy_private_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_constraint x0 -> - To.Parsetree.Pctf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pctf_attribute x0 -> - To.Parsetree.Pctf_attribute - (copy_attribute x0) - | From.Parsetree.Pctf_extension x0 -> - To.Parsetree.Pctf_extension - (copy_extension x0) - -and copy_extension : - From.Parsetree.extension -> - To.Parsetree.extension - = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload (from_loc x0) x1)) - -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.class_infos -> - 'g0 To.Parsetree.class_infos - = - fun f0 -> - fun - { From.Parsetree.pci_virt = pci_virt; - From.Parsetree.pci_params = pci_params; - From.Parsetree.pci_name = pci_name; - From.Parsetree.pci_expr = pci_expr; - From.Parsetree.pci_loc = pci_loc; - From.Parsetree.pci_attributes = pci_attributes } - -> - { - To.Parsetree.pci_virt = - (copy_virtual_flag pci_virt); - To.Parsetree.pci_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) pci_params); - To.Parsetree.pci_name = - (copy_loc (fun x -> x) pci_name); - To.Parsetree.pci_expr = (f0 pci_expr); - To.Parsetree.pci_loc = - (copy_location pci_loc); - To.Parsetree.pci_attributes = - (copy_attributes pci_attributes) - } - -and copy_virtual_flag : - From.Asttypes.virtual_flag -> - To.Asttypes.virtual_flag - = - function - | From.Asttypes.Virtual -> To.Asttypes.Virtual - | From.Asttypes.Concrete -> To.Asttypes.Concrete - -and copy_include_description : - From.Parsetree.include_description -> - To.Parsetree.include_description - = - fun x -> - copy_include_infos - copy_module_type x - -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.include_infos -> - 'g0 To.Parsetree.include_infos - = - fun f0 -> - fun - { From.Parsetree.pincl_mod = pincl_mod; - From.Parsetree.pincl_loc = pincl_loc; - From.Parsetree.pincl_attributes = pincl_attributes } - -> - { - To.Parsetree.pincl_mod = (f0 pincl_mod); - To.Parsetree.pincl_loc = - (copy_location pincl_loc); - To.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } - -and copy_open_description : - From.Parsetree.open_description -> - To.Parsetree.open_description - = - fun - { From.Parsetree.popen_lid = popen_lid; - From.Parsetree.popen_override = popen_override; - From.Parsetree.popen_loc = popen_loc; - From.Parsetree.popen_attributes = popen_attributes } - -> - { - To.Parsetree.popen_lid = - (copy_loc copy_longident - popen_lid); - To.Parsetree.popen_override = - (copy_override_flag popen_override); - To.Parsetree.popen_loc = - (copy_location popen_loc); - To.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } - -and copy_override_flag : - From.Asttypes.override_flag -> - To.Asttypes.override_flag - = - function - | From.Asttypes.Override -> To.Asttypes.Override - | From.Asttypes.Fresh -> To.Asttypes.Fresh - -and copy_module_type_declaration : - From.Parsetree.module_type_declaration -> - To.Parsetree.module_type_declaration - = - fun - { From.Parsetree.pmtd_name = pmtd_name; - From.Parsetree.pmtd_type = pmtd_type; - From.Parsetree.pmtd_attributes = pmtd_attributes; - From.Parsetree.pmtd_loc = pmtd_loc } - -> - { - To.Parsetree.pmtd_name = - (copy_loc (fun x -> x) pmtd_name); - To.Parsetree.pmtd_type = - (copy_option copy_module_type pmtd_type); - To.Parsetree.pmtd_attributes = - (copy_attributes pmtd_attributes); - To.Parsetree.pmtd_loc = - (copy_location pmtd_loc) - } - -and copy_module_declaration : - From.Parsetree.module_declaration -> - To.Parsetree.module_declaration - = - fun - { From.Parsetree.pmd_name = pmd_name; - From.Parsetree.pmd_type = pmd_type; - From.Parsetree.pmd_attributes = pmd_attributes; - From.Parsetree.pmd_loc = pmd_loc } - -> - { - To.Parsetree.pmd_name = - (copy_loc (fun x -> x) pmd_name); - To.Parsetree.pmd_type = - (copy_module_type pmd_type); - To.Parsetree.pmd_attributes = - (copy_attributes pmd_attributes); - To.Parsetree.pmd_loc = - (copy_location pmd_loc) - } - -and copy_type_extension : - From.Parsetree.type_extension -> - To.Parsetree.type_extension - = - fun - { From.Parsetree.ptyext_path = ptyext_path; - From.Parsetree.ptyext_params = ptyext_params; - From.Parsetree.ptyext_constructors = ptyext_constructors; - From.Parsetree.ptyext_private = ptyext_private; - From.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - To.Parsetree.ptyext_path = - (copy_loc copy_longident - ptyext_path); - To.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptyext_params); - To.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor - ptyext_constructors); - To.Parsetree.ptyext_private = - (copy_private_flag ptyext_private); - To.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } - -and copy_extension_constructor : - From.Parsetree.extension_constructor -> - To.Parsetree.extension_constructor - = - fun - { From.Parsetree.pext_name = pext_name; - From.Parsetree.pext_kind = pext_kind; - From.Parsetree.pext_loc = pext_loc; - From.Parsetree.pext_attributes = pext_attributes } - -> - { - To.Parsetree.pext_name = - (copy_loc (fun x -> x) pext_name); - To.Parsetree.pext_kind = - (copy_extension_constructor_kind (from_loc pext_name) pext_kind); - To.Parsetree.pext_loc = - (copy_location pext_loc); - To.Parsetree.pext_attributes = - (copy_attributes pext_attributes) - } - -and copy_extension_constructor_kind loc : - From.Parsetree.extension_constructor_kind -> - To.Parsetree.extension_constructor_kind - = - function - | From.Parsetree.Pext_decl (x0,x1) -> - To.Parsetree.Pext_decl - ((copy_constructor_arguments loc x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pext_rebind x0 -> - To.Parsetree.Pext_rebind - (copy_loc copy_longident - x0) - -and copy_type_declaration : - From.Parsetree.type_declaration -> - To.Parsetree.type_declaration - = - fun - { From.Parsetree.ptype_name = ptype_name; - From.Parsetree.ptype_params = ptype_params; - From.Parsetree.ptype_cstrs = ptype_cstrs; - From.Parsetree.ptype_kind = ptype_kind; - From.Parsetree.ptype_private = ptype_private; - From.Parsetree.ptype_manifest = ptype_manifest; - From.Parsetree.ptype_attributes = ptype_attributes; - From.Parsetree.ptype_loc = ptype_loc } - -> - { - To.Parsetree.ptype_name = - (copy_loc (fun x -> x) ptype_name); - To.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptype_params); - To.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0,x1,x2) = x in - ((copy_core_type x0), - (copy_core_type x1), - (copy_location x2))) ptype_cstrs); - To.Parsetree.ptype_kind = - (copy_type_kind ptype_kind); - To.Parsetree.ptype_private = - (copy_private_flag ptype_private); - To.Parsetree.ptype_manifest = - (copy_option copy_core_type ptype_manifest); - To.Parsetree.ptype_attributes = - (copy_attributes ptype_attributes); - To.Parsetree.ptype_loc = - (copy_location ptype_loc) - } - -and copy_private_flag : - From.Asttypes.private_flag -> - To.Asttypes.private_flag - = - function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - -and copy_type_kind : - From.Parsetree.type_kind -> - To.Parsetree.type_kind - = - function - | From.Parsetree.Ptype_abstract -> - To.Parsetree.Ptype_abstract - | From.Parsetree.Ptype_variant x0 -> - To.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | From.Parsetree.Ptype_record x0 -> - To.Parsetree.Ptype_record - (List.map copy_label_declaration x0) - | From.Parsetree.Ptype_open -> - To.Parsetree.Ptype_open - -and copy_constructor_declaration : - From.Parsetree.constructor_declaration -> - To.Parsetree.constructor_declaration - = - fun - { From.Parsetree.pcd_name = pcd_name; - From.Parsetree.pcd_args = pcd_args; - From.Parsetree.pcd_res = pcd_res; - From.Parsetree.pcd_loc = pcd_loc; - From.Parsetree.pcd_attributes = pcd_attributes } - -> - { - To.Parsetree.pcd_name = - (copy_loc (fun x -> x) pcd_name); - To.Parsetree.pcd_args = - (copy_constructor_arguments (from_loc pcd_name) pcd_args); - To.Parsetree.pcd_res = - (copy_option copy_core_type pcd_res); - To.Parsetree.pcd_loc = - (copy_location pcd_loc); - To.Parsetree.pcd_attributes = - (copy_attributes pcd_attributes) - } - -and copy_constructor_arguments loc : - From.Parsetree.constructor_arguments -> - To.Parsetree.core_type list - = - function - | From.Parsetree.Pcstr_tuple x0 -> - List.map copy_core_type x0 - | From.Parsetree.Pcstr_record _x0 -> - migration_error loc Def.Pcstr_record - -and copy_label_declaration : - From.Parsetree.label_declaration -> - To.Parsetree.label_declaration - = - fun - { From.Parsetree.pld_name = pld_name; - From.Parsetree.pld_mutable = pld_mutable; - From.Parsetree.pld_type = pld_type; - From.Parsetree.pld_loc = pld_loc; - From.Parsetree.pld_attributes = pld_attributes } - -> - { - To.Parsetree.pld_name = - (copy_loc (fun x -> x) pld_name); - To.Parsetree.pld_mutable = - (copy_mutable_flag pld_mutable); - To.Parsetree.pld_type = - (copy_core_type pld_type); - To.Parsetree.pld_loc = - (copy_location pld_loc); - To.Parsetree.pld_attributes = - (copy_attributes pld_attributes) - } - -and copy_mutable_flag : - From.Asttypes.mutable_flag -> - To.Asttypes.mutable_flag - = - function - | From.Asttypes.Immutable -> - To.Asttypes.Immutable - | From.Asttypes.Mutable -> To.Asttypes.Mutable - -and copy_variance : - From.Asttypes.variance -> To.Asttypes.variance = - function - | From.Asttypes.Covariant -> - To.Asttypes.Covariant - | From.Asttypes.Contravariant -> - To.Asttypes.Contravariant - | From.Asttypes.Invariant -> - To.Asttypes.Invariant - -and copy_value_description : - From.Parsetree.value_description -> - To.Parsetree.value_description - = - fun - { From.Parsetree.pval_name = pval_name; - From.Parsetree.pval_type = pval_type; - From.Parsetree.pval_prim = pval_prim; - From.Parsetree.pval_attributes = pval_attributes; - From.Parsetree.pval_loc = pval_loc } - -> - { - To.Parsetree.pval_name = - (copy_loc (fun x -> x) pval_name); - To.Parsetree.pval_type = - (copy_core_type pval_type); - To.Parsetree.pval_prim = - (List.map (fun x -> x) pval_prim); - To.Parsetree.pval_attributes = - (copy_attributes pval_attributes); - To.Parsetree.pval_loc = - (copy_location pval_loc) - } - -and copy_arg_label : - From.Asttypes.arg_label -> string - = - function - | From.Asttypes.Nolabel -> "" - | From.Asttypes.Labelled x0 -> x0 - | From.Asttypes.Optional x0 -> "?" ^ x0 - -and copy_closed_flag : - From.Asttypes.closed_flag -> - To.Asttypes.closed_flag - = - function - | From.Asttypes.Closed -> To.Asttypes.Closed - | From.Asttypes.Open -> To.Asttypes.Open - -and copy_label : - From.Asttypes.label -> To.Asttypes.label = - fun x -> x - -and copy_rec_flag : - From.Asttypes.rec_flag -> To.Asttypes.rec_flag = - function - | From.Asttypes.Nonrecursive -> - To.Asttypes.Nonrecursive - | From.Asttypes.Recursive -> - To.Asttypes.Recursive - -and copy_constant loc : - From.Parsetree.constant -> To.Asttypes.constant - = - function - | From.Parsetree.Pconst_integer (x0,x1) -> - begin match x1 with - | None -> To.Asttypes.Const_int (int_of_string x0) - | Some 'l' -> - To.Asttypes.Const_int32 (Int32.of_string x0) - | Some 'L' -> - To.Asttypes.Const_int64 (Int64.of_string x0) - | Some 'n' -> - To.Asttypes.Const_nativeint (Nativeint.of_string x0) - | Some _ -> migration_error loc Def.Pconst_integer - end - | From.Parsetree.Pconst_char x0 -> - To.Asttypes.Const_char x0 - | From.Parsetree.Pconst_string (x0,x1) -> - To.Asttypes.Const_string (x0,x1) - | From.Parsetree.Pconst_float (x0,x1) -> - begin match x1 with - | None -> To.Asttypes.Const_float x0 - | Some _ -> migration_error loc Def.Pconst_float - end - -and copy_option : 'f0 'g0 . ('f0 -> 'g0) -> 'f0 option -> 'g0 option = - fun f0 -> function | None -> None | Some x0 -> Some (f0 x0) - -and copy_longident : From.Longident.t -> To.Longident.t = function - | From.Longident.Lident x0 -> - To.Longident.Lident x0 - | From.Longident.Ldot (x0,x1) -> - To.Longident.Ldot - ((copy_longident x0), x1) - | From.Longident.Lapply (x0,x1) -> - To.Longident.Lapply - ((copy_longident x0), (copy_longident x1)) - -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc - = - fun f0 -> - fun - { From.Asttypes.txt = txt; - From.Asttypes.loc = loc } - -> - { - To.Asttypes.txt = (f0 txt); - To.Asttypes.loc = copy_location loc - } - -and copy_location : - From.Location.t -> To.Location.t = - fun - { From.Location.loc_start = loc_start; - From.Location.loc_end = loc_end; - From.Location.loc_ghost = loc_ghost } - -> - { - To.Location.loc_start = (copy_Lexing_position loc_start); - To.Location.loc_end = (copy_Lexing_position loc_end); - To.Location.loc_ghost = (copy_bool loc_ghost) - } - -and copy_bool : bool -> bool = function | false -> false | true -> true - -and copy_Lexing_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum + (fun x -> + let (x0, x1, x2) = x in + (x0, (List.map copy_out_type x1), + (Option.map copy_out_type x2))) otyext_constructors); + Ast_402.Outcometree.otyext_private = (copy_private_flag otyext_private) } - -and type_declarations recflag types = - match - (recflag, List.map copy_type_declaration types) - with - | From.Asttypes.Recursive, types -> types - | From.Asttypes.Nonrecursive, [] -> [] - | From.Asttypes.Nonrecursive, (x :: xs) -> - let pos = {Lexing. pos_fname = "_none_"; pos_lnum = 1; - pos_bol = 0; pos_cnum = -1} in - let loc = {To.Location. loc_start = pos; loc_end = pos; - loc_ghost = true} in - let ptype_attributes = - ({To.Asttypes.txt = "nonrec"; loc}, To.Parsetree.PStr []) :: - x.To.Parsetree.ptype_attributes - in - {x with To.Parsetree.ptype_attributes} :: xs - -let rec copy_out_phrase : - From.Outcometree.out_phrase -> To.Outcometree.out_phrase = +and copy_out_phrase : + Ast_403.Outcometree.out_phrase -> Ast_402.Outcometree.out_phrase = function - | From.Outcometree.Ophr_eval (x0,x1) -> - To.Outcometree.Ophr_eval - ((copy_out_value x0), - (copy_out_type x1)) - | From.Outcometree.Ophr_signature x0 -> - To.Outcometree.Ophr_signature + | Ast_403.Outcometree.Ophr_eval (x0, x1) -> + Ast_402.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1)) + | Ast_403.Outcometree.Ophr_signature x0 -> + Ast_402.Outcometree.Ophr_signature (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_sig_item x0), - (copy_option copy_out_value x1))) x0) - | From.Outcometree.Ophr_exception x0 -> - To.Outcometree.Ophr_exception - (let (x0,x1) = x0 in - ((copy_exn x0), (copy_out_value x1))) - -and copy_exn : exn -> exn = fun x -> x - + (fun x -> + let (x0, x1) = x in + ((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0) + | Ast_403.Outcometree.Ophr_exception x0 -> + Ast_402.Outcometree.Ophr_exception + (let (x0, x1) = x0 in (x0, (copy_out_value x1))) and copy_out_sig_item : - From.Outcometree.out_sig_item -> To.Outcometree.out_sig_item = + Ast_403.Outcometree.out_sig_item -> Ast_402.Outcometree.out_sig_item = function - | From.Outcometree.Osig_class (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class - ((copy_bool x0), x1, + | Ast_403.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> + Ast_402.Outcometree.Osig_class + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_class_type (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class_type - ((copy_bool x0), x1, + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_403.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> + Ast_402.Outcometree.Osig_class_type + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_typext (x0,x1) -> - To.Outcometree.Osig_typext - ((copy_out_extension_constructor x0), - (copy_out_ext_status x1)) - | From.Outcometree.Osig_modtype (x0,x1) -> - To.Outcometree.Osig_modtype - (x0, (copy_out_module_type x1)) - | From.Outcometree.Osig_module (x0,x1,x2) -> - To.Outcometree.Osig_module - (x0, (copy_out_module_type x1), - (copy_out_rec_status x2)) - | From.Outcometree.Osig_type (x0,x1) -> - To.Outcometree.Osig_type - ((copy_out_type_decl x0), - (copy_out_rec_status x1)) - | From.Outcometree.Osig_value x0 -> copy_out_val_decl x0 - | From.Outcometree.Osig_ellipsis -> + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_403.Outcometree.Osig_typext (x0, x1) -> + Ast_402.Outcometree.Osig_typext + ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) + | Ast_403.Outcometree.Osig_modtype (x0, x1) -> + Ast_402.Outcometree.Osig_modtype (x0, (copy_out_module_type x1)) + | Ast_403.Outcometree.Osig_module (x0, x1, x2) -> + Ast_402.Outcometree.Osig_module + (x0, (copy_out_module_type x1), (copy_out_rec_status x2)) + | Ast_403.Outcometree.Osig_type (x0, x1) -> + Ast_402.Outcometree.Osig_type + ((copy_out_type_decl x0), (copy_out_rec_status x1)) + | Ast_403.Outcometree.Osig_value x0 -> (copy_out_val_decl x0) + | Ast_403.Outcometree.Osig_ellipsis -> To.Outcometree.Osig_value ("...", To.Outcometree.Otyp_abstract, []) and copy_out_val_decl : @@ -1619,6 +83,12 @@ and copy_out_val_decl : List.map (fun x -> x) oval_prims ) +and copy_From_Asttypes_private_flag : + From.Asttypes.private_flag -> To.Asttypes.private_flag = + function + | From.Asttypes.Private -> To.Asttypes.Private + | From.Asttypes.Public -> To.Asttypes.Public + and copy_out_type_decl : From.Outcometree.out_type_decl -> To.Outcometree.out_type_decl = fun @@ -1635,7 +105,7 @@ and copy_out_type_decl : (List.map (fun x -> let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) + (x0, (let (x0,x1) = x1 in (x0, x1)))) otype_params); To.Outcometree.otype_type = (copy_out_type otype_type); @@ -1649,293 +119,190 @@ and copy_out_type_decl : ((copy_out_type x0), (copy_out_type x1))) otype_cstrs) } - and copy_out_module_type : - From.Outcometree.out_module_type -> To.Outcometree.out_module_type - = - function - | From.Outcometree.Omty_abstract -> To.Outcometree.Omty_abstract - | From.Outcometree.Omty_functor (x0,x1,x2) -> - To.Outcometree.Omty_functor - (x0, (copy_option copy_out_module_type x1), - (copy_out_module_type x2)) - | From.Outcometree.Omty_ident x0 -> - To.Outcometree.Omty_ident (copy_out_ident x0) - | From.Outcometree.Omty_signature x0 -> - To.Outcometree.Omty_signature - (List.map copy_out_sig_item x0) - | From.Outcometree.Omty_alias x0 -> - To.Outcometree.Omty_alias (copy_out_ident x0) - + Ast_403.Outcometree.out_module_type -> Ast_402.Outcometree.out_module_type + = + function + | Ast_403.Outcometree.Omty_abstract -> Ast_402.Outcometree.Omty_abstract + | Ast_403.Outcometree.Omty_functor (x0, x1, x2) -> + Ast_402.Outcometree.Omty_functor + (x0, (Option.map copy_out_module_type x1), (copy_out_module_type x2)) + | Ast_403.Outcometree.Omty_ident x0 -> + Ast_402.Outcometree.Omty_ident (copy_out_ident x0) + | Ast_403.Outcometree.Omty_signature x0 -> + Ast_402.Outcometree.Omty_signature (List.map copy_out_sig_item x0) + | Ast_403.Outcometree.Omty_alias x0 -> + Ast_402.Outcometree.Omty_alias (copy_out_ident x0) and copy_out_ext_status : - From.Outcometree.out_ext_status -> To.Outcometree.out_ext_status = + Ast_403.Outcometree.out_ext_status -> Ast_402.Outcometree.out_ext_status = function - | From.Outcometree.Oext_first -> To.Outcometree.Oext_first - | From.Outcometree.Oext_next -> To.Outcometree.Oext_next - | From.Outcometree.Oext_exception -> To.Outcometree.Oext_exception - + | Ast_403.Outcometree.Oext_first -> Ast_402.Outcometree.Oext_first + | Ast_403.Outcometree.Oext_next -> Ast_402.Outcometree.Oext_next + | Ast_403.Outcometree.Oext_exception -> Ast_402.Outcometree.Oext_exception and copy_out_extension_constructor : - From.Outcometree.out_extension_constructor -> - To.Outcometree.out_extension_constructor + Ast_403.Outcometree.out_extension_constructor -> + Ast_402.Outcometree.out_extension_constructor = fun - { From.Outcometree.oext_name = oext_name; - From.Outcometree.oext_type_name = oext_type_name; - From.Outcometree.oext_type_params = oext_type_params; - From.Outcometree.oext_args = oext_args; - From.Outcometree.oext_ret_type = oext_ret_type; - From.Outcometree.oext_private = oext_private } - -> + { Ast_403.Outcometree.oext_name = oext_name; + Ast_403.Outcometree.oext_type_name = oext_type_name; + Ast_403.Outcometree.oext_type_params = oext_type_params; + Ast_403.Outcometree.oext_args = oext_args; + Ast_403.Outcometree.oext_ret_type = oext_ret_type; + Ast_403.Outcometree.oext_private = oext_private } + -> { - To.Outcometree.oext_name = oext_name; - To.Outcometree.oext_type_name = oext_type_name; - To.Outcometree.oext_type_params = - (List.map (fun x -> x) oext_type_params); - To.Outcometree.oext_args = - (List.map copy_out_type oext_args); - To.Outcometree.oext_ret_type = - (copy_option copy_out_type oext_ret_type); - To.Outcometree.oext_private = - (copy_From_Asttypes_private_flag oext_private) + Ast_402.Outcometree.oext_name = oext_name; + Ast_402.Outcometree.oext_type_name = oext_type_name; + Ast_402.Outcometree.oext_type_params = + (List.map (fun x -> x) oext_type_params); + Ast_402.Outcometree.oext_args = (List.map copy_out_type oext_args); + Ast_402.Outcometree.oext_ret_type = + (Option.map copy_out_type oext_ret_type); + Ast_402.Outcometree.oext_private = (copy_private_flag oext_private) } - -and copy_From_Asttypes_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = +and copy_private_flag : + Ast_403.Asttypes.private_flag -> Ast_402.Asttypes.private_flag = function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - + | Ast_403.Asttypes.Private -> Ast_402.Asttypes.Private + | Ast_403.Asttypes.Public -> Ast_402.Asttypes.Public and copy_out_rec_status : - From.Outcometree.out_rec_status -> To.Outcometree.out_rec_status = + Ast_403.Outcometree.out_rec_status -> Ast_402.Outcometree.out_rec_status = function - | From.Outcometree.Orec_not -> To.Outcometree.Orec_not - | From.Outcometree.Orec_first -> To.Outcometree.Orec_first - | From.Outcometree.Orec_next -> To.Outcometree.Orec_next - + | Ast_403.Outcometree.Orec_not -> Ast_402.Outcometree.Orec_not + | Ast_403.Outcometree.Orec_first -> Ast_402.Outcometree.Orec_first + | Ast_403.Outcometree.Orec_next -> Ast_402.Outcometree.Orec_next and copy_out_class_type : - From.Outcometree.out_class_type -> To.Outcometree.out_class_type = - function - | From.Outcometree.Octy_constr (x0,x1) -> - To.Outcometree.Octy_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Octy_arrow (x0,x1,x2) -> - To.Outcometree.Octy_arrow - (x0, (copy_out_type x1), - (copy_out_class_type x2)) - | From.Outcometree.Octy_signature (x0,x1) -> - To.Outcometree.Octy_signature - ((copy_option copy_out_type x0), + Ast_403.Outcometree.out_class_type -> Ast_402.Outcometree.out_class_type = + function + | Ast_403.Outcometree.Octy_constr (x0, x1) -> + Ast_402.Outcometree.Octy_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_403.Outcometree.Octy_arrow (x0, x1, x2) -> + Ast_402.Outcometree.Octy_arrow + (x0, (copy_out_type x1), (copy_out_class_type x2)) + | Ast_403.Outcometree.Octy_signature (x0, x1) -> + Ast_402.Outcometree.Octy_signature + ((Option.map copy_out_type x0), (List.map copy_out_class_sig_item x1)) - and copy_out_class_sig_item : - From.Outcometree.out_class_sig_item -> - To.Outcometree.out_class_sig_item + Ast_403.Outcometree.out_class_sig_item -> + Ast_402.Outcometree.out_class_sig_item = function - | From.Outcometree.Ocsg_constraint (x0,x1) -> - To.Outcometree.Ocsg_constraint - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Ocsg_method (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_method - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - | From.Outcometree.Ocsg_value (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_value - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - + | Ast_403.Outcometree.Ocsg_constraint (x0, x1) -> + Ast_402.Outcometree.Ocsg_constraint + ((copy_out_type x0), (copy_out_type x1)) + | Ast_403.Outcometree.Ocsg_method (x0, x1, x2, x3) -> + Ast_402.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3)) + | Ast_403.Outcometree.Ocsg_value (x0, x1, x2, x3) -> + Ast_402.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3)) and copy_out_type : - From.Outcometree.out_type -> To.Outcometree.out_type = - function - | From.Outcometree.Otyp_abstract -> To.Outcometree.Otyp_abstract - | From.Outcometree.Otyp_open -> To.Outcometree.Otyp_open - | From.Outcometree.Otyp_alias (x0,x1) -> - To.Outcometree.Otyp_alias - ((copy_out_type x0), x1) - | From.Outcometree.Otyp_arrow (x0,x1,x2) -> - To.Outcometree.Otyp_arrow - (x0, (copy_out_type x1), - (copy_out_type x2)) - | From.Outcometree.Otyp_class (x0,x1,x2) -> - To.Outcometree.Otyp_class - ((copy_bool x0), (copy_out_ident x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_constr (x0,x1) -> - To.Outcometree.Otyp_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Otyp_manifest (x0,x1) -> - To.Outcometree.Otyp_manifest - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Otyp_object (x0,x1) -> - To.Outcometree.Otyp_object - ((List.map - (fun x -> - let (x0,x1) = x in - (x0, (copy_out_type x1))) x0), - (copy_option copy_bool x1)) - | From.Outcometree.Otyp_record x0 -> - To.Outcometree.Otyp_record + Ast_403.Outcometree.out_type -> Ast_402.Outcometree.out_type = + function + | Ast_403.Outcometree.Otyp_abstract -> Ast_402.Outcometree.Otyp_abstract + | Ast_403.Outcometree.Otyp_open -> Ast_402.Outcometree.Otyp_open + | Ast_403.Outcometree.Otyp_alias (x0, x1) -> + Ast_402.Outcometree.Otyp_alias ((copy_out_type x0), x1) + | Ast_403.Outcometree.Otyp_arrow (x0, x1, x2) -> + Ast_402.Outcometree.Otyp_arrow + (x0, (copy_out_type x1), (copy_out_type x2)) + | Ast_403.Outcometree.Otyp_class (x0, x1, x2) -> + Ast_402.Outcometree.Otyp_class + (x0, (copy_out_ident x1), (List.map copy_out_type x2)) + | Ast_403.Outcometree.Otyp_constr (x0, x1) -> + Ast_402.Outcometree.Otyp_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_403.Outcometree.Otyp_manifest (x0, x1) -> + Ast_402.Outcometree.Otyp_manifest + ((copy_out_type x0), (copy_out_type x1)) + | Ast_403.Outcometree.Otyp_object (x0, x1) -> + Ast_402.Outcometree.Otyp_object + ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0), + (Option.map (fun x -> x) x1)) + | Ast_403.Outcometree.Otyp_record x0 -> + Ast_402.Outcometree.Otyp_record (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), (copy_out_type x2))) - x0) - | From.Outcometree.Otyp_stuff x0 -> To.Outcometree.Otyp_stuff x0 - | From.Outcometree.Otyp_sum x0 -> - To.Outcometree.Otyp_sum + (fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0) + | Ast_403.Outcometree.Otyp_stuff x0 -> Ast_402.Outcometree.Otyp_stuff x0 + | Ast_403.Outcometree.Otyp_sum x0 -> + Ast_402.Outcometree.Otyp_sum (List.map - (fun x -> - let (x0,x1,x2) = x in + (fun x -> + let (x0, x1, x2) = x in (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) x0) - | From.Outcometree.Otyp_tuple x0 -> - To.Outcometree.Otyp_tuple - (List.map copy_out_type x0) - | From.Outcometree.Otyp_var (x0,x1) -> - To.Outcometree.Otyp_var ((copy_bool x0), x1) - | From.Outcometree.Otyp_variant (x0,x1,x2,x3) -> - To.Outcometree.Otyp_variant - ((copy_bool x0), (copy_out_variant x1), - (copy_bool x2), - (copy_option (fun x -> List.map (fun x -> x) x) x3)) - | From.Outcometree.Otyp_poly (x0,x1) -> - To.Outcometree.Otyp_poly - ((List.map (fun x -> x) x0), (copy_out_type x1)) - | From.Outcometree.Otyp_module (x0,x1,x2) -> - To.Outcometree.Otyp_module - (x0, (List.map (fun x -> x) x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_attribute (_x0,_x1) -> - To.Outcometree.Otyp_abstract - (*To.Outcometree.Otyp_attribute - ((copy_out_type x0), - (copy_out_attribute x1))*) - -(*and copy_out_attribute : - From.Outcometree.out_attribute -> To.Outcometree.out_attribute = - fun { From.Outcometree.oattr_name = oattr_name } -> - { To.Outcometree.oattr_name = oattr_name }*) - + (Option.map copy_out_type x2))) x0) + | Ast_403.Outcometree.Otyp_tuple x0 -> + Ast_402.Outcometree.Otyp_tuple (List.map copy_out_type x0) + | Ast_403.Outcometree.Otyp_var (x0, x1) -> + Ast_402.Outcometree.Otyp_var (x0, x1) + | Ast_403.Outcometree.Otyp_variant (x0, x1, x2, x3) -> + Ast_402.Outcometree.Otyp_variant + (x0, (copy_out_variant x1), x2, + (Option.map (fun x -> List.map (fun x -> x) x) x3)) + | Ast_403.Outcometree.Otyp_poly (x0, x1) -> + Ast_402.Outcometree.Otyp_poly + ((List.map (fun x -> x) x0), (copy_out_type x1)) + | Ast_403.Outcometree.Otyp_module (x0, x1, x2) -> + Ast_402.Outcometree.Otyp_module + (x0, (List.map (fun x -> x) x1), (List.map copy_out_type x2)) + | Ast_403.Outcometree.Otyp_attribute _ -> + Ast_402.Outcometree.Otyp_abstract + (* ((copy_out_type x0), (copy_out_attribute x1)) *) +(* and copy_out_attribute : *) + (* Ast_403.Outcometree.out_attribute -> Ast_402.Outcometree.out_attribute = *) + (* fun { Ast_403.Outcometree.oattr_name = oattr_name } -> *) + (* { Ast_402.Outcometree.oattr_name = oattr_name } *) and copy_out_variant : - From.Outcometree.out_variant -> To.Outcometree.out_variant = + Ast_403.Outcometree.out_variant -> Ast_402.Outcometree.out_variant = function - | From.Outcometree.Ovar_fields x0 -> - To.Outcometree.Ovar_fields + | Ast_403.Outcometree.Ovar_fields x0 -> + Ast_402.Outcometree.Ovar_fields (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), - (List.map copy_out_type x2))) x0) - | From.Outcometree.Ovar_name (x0,x1) -> - To.Outcometree.Ovar_name - ((copy_out_ident x0), - (List.map copy_out_type x1)) - + (fun x -> + let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2))) + x0) + | Ast_403.Outcometree.Ovar_name (x0, x1) -> + Ast_402.Outcometree.Ovar_name + ((copy_out_ident x0), (List.map copy_out_type x1)) and copy_out_value : - From.Outcometree.out_value -> To.Outcometree.out_value = - function - | From.Outcometree.Oval_array x0 -> - To.Outcometree.Oval_array - (List.map copy_out_value x0) - | From.Outcometree.Oval_char x0 -> To.Outcometree.Oval_char x0 - | From.Outcometree.Oval_constr (x0,x1) -> - To.Outcometree.Oval_constr - ((copy_out_ident x0), - (List.map copy_out_value x1)) - | From.Outcometree.Oval_ellipsis -> To.Outcometree.Oval_ellipsis - | From.Outcometree.Oval_float x0 -> - To.Outcometree.Oval_float (copy_float x0) - | From.Outcometree.Oval_int x0 -> To.Outcometree.Oval_int x0 - | From.Outcometree.Oval_int32 x0 -> To.Outcometree.Oval_int32 x0 - | From.Outcometree.Oval_int64 x0 -> To.Outcometree.Oval_int64 x0 - | From.Outcometree.Oval_nativeint x0 -> - To.Outcometree.Oval_nativeint x0 - | From.Outcometree.Oval_list x0 -> - To.Outcometree.Oval_list - (List.map copy_out_value x0) - | From.Outcometree.Oval_printer x0 -> - To.Outcometree.Oval_printer x0 - | From.Outcometree.Oval_record x0 -> - To.Outcometree.Oval_record + Ast_403.Outcometree.out_value -> Ast_402.Outcometree.out_value = + function + | Ast_403.Outcometree.Oval_array x0 -> + Ast_402.Outcometree.Oval_array (List.map copy_out_value x0) + | Ast_403.Outcometree.Oval_char x0 -> Ast_402.Outcometree.Oval_char x0 + | Ast_403.Outcometree.Oval_constr (x0, x1) -> + Ast_402.Outcometree.Oval_constr + ((copy_out_ident x0), (List.map copy_out_value x1)) + | Ast_403.Outcometree.Oval_ellipsis -> Ast_402.Outcometree.Oval_ellipsis + | Ast_403.Outcometree.Oval_float x0 -> Ast_402.Outcometree.Oval_float x0 + | Ast_403.Outcometree.Oval_int x0 -> Ast_402.Outcometree.Oval_int x0 + | Ast_403.Outcometree.Oval_int32 x0 -> Ast_402.Outcometree.Oval_int32 x0 + | Ast_403.Outcometree.Oval_int64 x0 -> Ast_402.Outcometree.Oval_int64 x0 + | Ast_403.Outcometree.Oval_nativeint x0 -> + Ast_402.Outcometree.Oval_nativeint x0 + | Ast_403.Outcometree.Oval_list x0 -> + Ast_402.Outcometree.Oval_list (List.map copy_out_value x0) + | Ast_403.Outcometree.Oval_printer x0 -> + Ast_402.Outcometree.Oval_printer x0 + | Ast_403.Outcometree.Oval_record x0 -> + Ast_402.Outcometree.Oval_record (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_ident x0), - (copy_out_value x1))) x0) - | From.Outcometree.Oval_string x0 -> To.Outcometree.Oval_string x0 - | From.Outcometree.Oval_stuff x0 -> To.Outcometree.Oval_stuff x0 - | From.Outcometree.Oval_tuple x0 -> - To.Outcometree.Oval_tuple - (List.map copy_out_value x0) - | From.Outcometree.Oval_variant (x0,x1) -> - To.Outcometree.Oval_variant - (x0, (copy_option copy_out_value x1)) - -and copy_float : float -> float = fun x -> x - + (fun x -> + let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1))) + x0) + | Ast_403.Outcometree.Oval_string x0 -> Ast_402.Outcometree.Oval_string x0 + | Ast_403.Outcometree.Oval_stuff x0 -> Ast_402.Outcometree.Oval_stuff x0 + | Ast_403.Outcometree.Oval_tuple x0 -> + Ast_402.Outcometree.Oval_tuple (List.map copy_out_value x0) + | Ast_403.Outcometree.Oval_variant (x0, x1) -> + Ast_402.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1)) and copy_out_ident : - From.Outcometree.out_ident -> To.Outcometree.out_ident = - function - | From.Outcometree.Oide_apply (x0,x1) -> - To.Outcometree.Oide_apply - ((copy_out_ident x0), - (copy_out_ident x1)) - | From.Outcometree.Oide_dot (x0,x1) -> - To.Outcometree.Oide_dot - ((copy_out_ident x0), x1) - | From.Outcometree.Oide_ident x0 -> To.Outcometree.Oide_ident x0 - -let rec copy_toplevel_phrase : - From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = - function - | From.Parsetree.Ptop_def x0 -> - To.Parsetree.Ptop_def (copy_structure x0) - | From.Parsetree.Ptop_dir (x0,x1) -> - To.Parsetree.Ptop_dir - (x0, (copy_directive_argument x1)) - -and copy_directive_argument : - From.Parsetree.directive_argument -> - To.Parsetree.directive_argument - = - function - | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none - | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 - | From.Parsetree.Pdir_int (x0,_x1) -> - To.Parsetree.Pdir_int (int_of_string x0) - | From.Parsetree.Pdir_ident x0 -> - To.Parsetree.Pdir_ident (copy_longident x0) - | From.Parsetree.Pdir_bool x0 -> - To.Parsetree.Pdir_bool (copy_bool x0) - -let copy_out_type_extension : - From.Outcometree.out_type_extension -> To.Outcometree.out_type_extension = - fun - { From.Outcometree.otyext_name = otyext_name; - From.Outcometree.otyext_params = otyext_params; - From.Outcometree.otyext_constructors = otyext_constructors; - From.Outcometree.otyext_private = otyext_private } - -> - { - To.Outcometree.otyext_name = otyext_name; - To.Outcometree.otyext_params = - (List.map (fun x -> x) otyext_params); - To.Outcometree.otyext_constructors = - (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) - otyext_constructors); - To.Outcometree.otyext_private = - (copy_private_flag otyext_private) - } - -let copy_cases x = List.map copy_case x -let copy_pat = copy_pattern -let copy_expr = copy_expression -let copy_typ = copy_core_type + Ast_403.Outcometree.out_ident -> Ast_402.Outcometree.out_ident = + function + | Ast_403.Outcometree.Oide_apply (x0, x1) -> + Ast_402.Outcometree.Oide_apply + ((copy_out_ident x0), (copy_out_ident x1)) + | Ast_403.Outcometree.Oide_dot (x0, x1) -> + Ast_402.Outcometree.Oide_dot ((copy_out_ident x0), x1) + | Ast_403.Outcometree.Oide_ident x0 -> Ast_402.Outcometree.Oide_ident x0 diff --git a/src/vendored-omp/src/migrate_parsetree_403_404.ml b/src/vendored-omp/src/migrate_parsetree_403_404.ml index 06a5a6831..b03096444 100644 --- a/src/vendored-omp/src/migrate_parsetree_403_404.ml +++ b/src/vendored-omp/src/migrate_parsetree_403_404.ml @@ -15,116 +15,3 @@ include Migrate_parsetree_403_404_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - (*$*) - } as mapper) -> - let module R = Migrate_parsetree_404_403_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_403_404_migrate.ml b/src/vendored-omp/src/migrate_parsetree_403_404_migrate.ml index 2fa97c316..139259cf1 100644 --- a/src/vendored-omp/src/migrate_parsetree_403_404_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_403_404_migrate.ml @@ -1,1596 +1,95 @@ -(**************************************************************************) -(* *) -(* OCaml Migrate Parsetree *) -(* *) -(* Frédéric Bour *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2017 Institut National de Recherche en Informatique et *) -(* en Automatique (INRIA). *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - +open Stdlib0 module From = Ast_403 module To = Ast_404 - -let rec copy_expression : - From.Parsetree.expression -> - To.Parsetree.expression +let rec copy_out_type_extension : + Ast_403.Outcometree.out_type_extension -> + Ast_404.Outcometree.out_type_extension = fun - { From.Parsetree.pexp_desc = pexp_desc; - From.Parsetree.pexp_loc = pexp_loc; - From.Parsetree.pexp_attributes = pexp_attributes } - -> + { Ast_403.Outcometree.otyext_name = otyext_name; + Ast_403.Outcometree.otyext_params = otyext_params; + Ast_403.Outcometree.otyext_constructors = otyext_constructors; + Ast_403.Outcometree.otyext_private = otyext_private } + -> { - To.Parsetree.pexp_desc = - (copy_expression_desc pexp_desc); - To.Parsetree.pexp_loc = - (copy_location pexp_loc); - To.Parsetree.pexp_attributes = - (copy_attributes pexp_attributes) - } - -and copy_expression_desc : - From.Parsetree.expression_desc -> - To.Parsetree.expression_desc - = - function - | From.Parsetree.Pexp_ident x0 -> - To.Parsetree.Pexp_ident - (copy_loc copy_longident - x0) - | From.Parsetree.Pexp_constant x0 -> - To.Parsetree.Pexp_constant - (copy_constant x0) - | From.Parsetree.Pexp_let (x0,x1,x2) -> - To.Parsetree.Pexp_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_expression x2)) - | From.Parsetree.Pexp_function x0 -> - To.Parsetree.Pexp_function - (List.map copy_case x0) - | From.Parsetree.Pexp_fun (x0,x1,x2,x3) -> - To.Parsetree.Pexp_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_expression x3)) - | From.Parsetree.Pexp_apply (x0,x1) -> - To.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pexp_match (x0,x1) -> - To.Parsetree.Pexp_match - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_try (x0,x1) -> - To.Parsetree.Pexp_try - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_tuple x0 -> - To.Parsetree.Pexp_tuple - (List.map copy_expression x0) - | From.Parsetree.Pexp_construct (x0,x1) -> - To.Parsetree.Pexp_construct - ((copy_loc - copy_longident x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_variant (x0,x1) -> - To.Parsetree.Pexp_variant - ((copy_label x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_record (x0,x1) -> - To.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc - copy_longident x0), - (copy_expression x1))) x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_field (x0,x1) -> - To.Parsetree.Pexp_field - ((copy_expression x0), - (copy_loc - copy_longident x1)) - | From.Parsetree.Pexp_setfield (x0,x1,x2) -> - To.Parsetree.Pexp_setfield - ((copy_expression x0), - (copy_loc - copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_array x0 -> - To.Parsetree.Pexp_array - (List.map copy_expression x0) - | From.Parsetree.Pexp_ifthenelse (x0,x1,x2) -> - To.Parsetree.Pexp_ifthenelse - ((copy_expression x0), - (copy_expression x1), - (copy_option copy_expression x2)) - | From.Parsetree.Pexp_sequence (x0,x1) -> - To.Parsetree.Pexp_sequence - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_while (x0,x1) -> - To.Parsetree.Pexp_while - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_for (x0,x1,x2,x3,x4) -> - To.Parsetree.Pexp_for - ((copy_pattern x0), - (copy_expression x1), - (copy_expression x2), - (copy_direction_flag x3), - (copy_expression x4)) - | From.Parsetree.Pexp_constraint (x0,x1) -> - To.Parsetree.Pexp_constraint - ((copy_expression x0), - (copy_core_type x1)) - | From.Parsetree.Pexp_coerce (x0,x1,x2) -> - To.Parsetree.Pexp_coerce - ((copy_expression x0), - (copy_option copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Pexp_send (x0,x1) -> - To.Parsetree.Pexp_send - ((copy_expression x0), x1) - | From.Parsetree.Pexp_new x0 -> - To.Parsetree.Pexp_new - (copy_loc copy_longident - x0) - | From.Parsetree.Pexp_setinstvar (x0,x1) -> - To.Parsetree.Pexp_setinstvar - ((copy_loc (fun x -> x) x0), - (copy_expression x1)) - | From.Parsetree.Pexp_override x0 -> - To.Parsetree.Pexp_override + Ast_404.Outcometree.otyext_name = otyext_name; + Ast_404.Outcometree.otyext_params = + (List.map (fun x -> x) otyext_params); + Ast_404.Outcometree.otyext_constructors = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_expression x1))) x0) - | From.Parsetree.Pexp_letmodule (x0,x1,x2) -> - To.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> x) x0), - (copy_module_expr x1), - (copy_expression x2)) - | From.Parsetree.Pexp_assert x0 -> - To.Parsetree.Pexp_assert - (copy_expression x0) - | From.Parsetree.Pexp_lazy x0 -> - To.Parsetree.Pexp_lazy - (copy_expression x0) - | From.Parsetree.Pexp_poly (x0,x1) -> - To.Parsetree.Pexp_poly - ((copy_expression x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pexp_object x0 -> - To.Parsetree.Pexp_object - (copy_class_structure x0) - | From.Parsetree.Pexp_newtype (x0,x1) -> - To.Parsetree.Pexp_newtype - (x0, (copy_expression x1)) - | From.Parsetree.Pexp_pack x0 -> - To.Parsetree.Pexp_pack - (copy_module_expr x0) - | From.Parsetree.Pexp_open (x0,x1,x2) -> - To.Parsetree.Pexp_open - ((copy_override_flag x0), - (copy_loc - copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_extension x0 -> - To.Parsetree.Pexp_extension - (copy_extension x0) - | From.Parsetree.Pexp_unreachable -> - To.Parsetree.Pexp_unreachable - -and copy_direction_flag : - From.Asttypes.direction_flag -> - To.Asttypes.direction_flag - = - function - | From.Asttypes.Upto -> To.Asttypes.Upto - | From.Asttypes.Downto -> To.Asttypes.Downto - -and copy_case : - From.Parsetree.case -> To.Parsetree.case = - fun - { From.Parsetree.pc_lhs = pc_lhs; - From.Parsetree.pc_guard = pc_guard; - From.Parsetree.pc_rhs = pc_rhs } - -> - { - To.Parsetree.pc_lhs = - (copy_pattern pc_lhs); - To.Parsetree.pc_guard = - (copy_option copy_expression pc_guard); - To.Parsetree.pc_rhs = - (copy_expression pc_rhs) - } - -and copy_value_binding : - From.Parsetree.value_binding -> - To.Parsetree.value_binding - = - fun - { From.Parsetree.pvb_pat = pvb_pat; - From.Parsetree.pvb_expr = pvb_expr; - From.Parsetree.pvb_attributes = pvb_attributes; - From.Parsetree.pvb_loc = pvb_loc } - -> - { - To.Parsetree.pvb_pat = - (copy_pattern pvb_pat); - To.Parsetree.pvb_expr = - (copy_expression pvb_expr); - To.Parsetree.pvb_attributes = - (copy_attributes pvb_attributes); - To.Parsetree.pvb_loc = - (copy_location pvb_loc) - } - -and copy_pattern : - From.Parsetree.pattern -> To.Parsetree.pattern = - fun - { From.Parsetree.ppat_desc = ppat_desc; - From.Parsetree.ppat_loc = ppat_loc; - From.Parsetree.ppat_attributes = ppat_attributes } - -> - { - To.Parsetree.ppat_desc = - (copy_pattern_desc ppat_desc); - To.Parsetree.ppat_loc = - (copy_location ppat_loc); - To.Parsetree.ppat_attributes = - (copy_attributes ppat_attributes) - } - -and copy_pattern_desc : - From.Parsetree.pattern_desc -> - To.Parsetree.pattern_desc - = - function - | From.Parsetree.Ppat_any -> - To.Parsetree.Ppat_any - | From.Parsetree.Ppat_var x0 -> - To.Parsetree.Ppat_var - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_alias (x0,x1) -> - To.Parsetree.Ppat_alias - ((copy_pattern x0), - (copy_loc (fun x -> x) x1)) - | From.Parsetree.Ppat_constant x0 -> - To.Parsetree.Ppat_constant - (copy_constant x0) - | From.Parsetree.Ppat_interval (x0,x1) -> - To.Parsetree.Ppat_interval - ((copy_constant x0), - (copy_constant x1)) - | From.Parsetree.Ppat_tuple x0 -> - To.Parsetree.Ppat_tuple - (List.map copy_pattern x0) - | From.Parsetree.Ppat_construct (x0,x1) -> - To.Parsetree.Ppat_construct - ((copy_loc - copy_longident x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_variant (x0,x1) -> - To.Parsetree.Ppat_variant - ((copy_label x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_record (x0,x1) -> - To.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc - copy_longident x0), - (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ppat_array x0 -> - To.Parsetree.Ppat_array - (List.map copy_pattern x0) - | From.Parsetree.Ppat_or (x0,x1) -> - To.Parsetree.Ppat_or - ((copy_pattern x0), - (copy_pattern x1)) - | From.Parsetree.Ppat_constraint (x0,x1) -> - To.Parsetree.Ppat_constraint - ((copy_pattern x0), - (copy_core_type x1)) - | From.Parsetree.Ppat_type x0 -> - To.Parsetree.Ppat_type - (copy_loc copy_longident - x0) - | From.Parsetree.Ppat_lazy x0 -> - To.Parsetree.Ppat_lazy - (copy_pattern x0) - | From.Parsetree.Ppat_unpack x0 -> - To.Parsetree.Ppat_unpack - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_exception x0 -> - To.Parsetree.Ppat_exception - (copy_pattern x0) - | From.Parsetree.Ppat_extension x0 -> - To.Parsetree.Ppat_extension - (copy_extension x0) - -and copy_core_type : - From.Parsetree.core_type -> - To.Parsetree.core_type - = - fun - { From.Parsetree.ptyp_desc = ptyp_desc; - From.Parsetree.ptyp_loc = ptyp_loc; - From.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - To.Parsetree.ptyp_desc = - (copy_core_type_desc ptyp_desc); - To.Parsetree.ptyp_loc = - (copy_location ptyp_loc); - To.Parsetree.ptyp_attributes = - (copy_attributes ptyp_attributes) - } - -and copy_core_type_desc : - From.Parsetree.core_type_desc -> - To.Parsetree.core_type_desc - = - function - | From.Parsetree.Ptyp_any -> - To.Parsetree.Ptyp_any - | From.Parsetree.Ptyp_var x0 -> - To.Parsetree.Ptyp_var x0 - | From.Parsetree.Ptyp_arrow (x0,x1,x2) -> - To.Parsetree.Ptyp_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Ptyp_tuple x0 -> - To.Parsetree.Ptyp_tuple - (List.map copy_core_type x0) - | From.Parsetree.Ptyp_constr (x0,x1) -> - To.Parsetree.Ptyp_constr - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_object (x0,x1) -> - To.Parsetree.Ptyp_object - ((List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_attributes x1), - (copy_core_type x2))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ptyp_class (x0,x1) -> - To.Parsetree.Ptyp_class - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_alias (x0,x1) -> - To.Parsetree.Ptyp_alias - ((copy_core_type x0), x1) - | From.Parsetree.Ptyp_variant (x0,x1,x2) -> - To.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), - (copy_closed_flag x1), - (copy_option - (fun x -> List.map copy_label x) x2)) - | From.Parsetree.Ptyp_poly (x0,x1) -> - To.Parsetree.Ptyp_poly - ((List.map (fun x -> x) x0), - (copy_core_type x1)) - | From.Parsetree.Ptyp_package x0 -> - To.Parsetree.Ptyp_package - (copy_package_type x0) - | From.Parsetree.Ptyp_extension x0 -> - To.Parsetree.Ptyp_extension - (copy_extension x0) - -and copy_package_type : - From.Parsetree.package_type -> - To.Parsetree.package_type - = - fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc - copy_longident x0), - (copy_core_type x1))) x1)) - -and copy_row_field : - From.Parsetree.row_field -> - To.Parsetree.row_field - = - function - | From.Parsetree.Rtag (x0,x1,x2,x3) -> - To.Parsetree.Rtag - ((copy_label x0), - (copy_attributes x1), (copy_bool x2), - (List.map copy_core_type x3)) - | From.Parsetree.Rinherit x0 -> - To.Parsetree.Rinherit - (copy_core_type x0) - -and copy_attributes : - From.Parsetree.attributes -> - To.Parsetree.attributes - = fun x -> List.map copy_attribute x - -and copy_attribute : - From.Parsetree.attribute -> - To.Parsetree.attribute - = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_payload : - From.Parsetree.payload -> To.Parsetree.payload = - function - | From.Parsetree.PStr x0 -> - To.Parsetree.PStr - (copy_structure x0) - | From.Parsetree.PSig x0 -> - To.Parsetree.PSig - (copy_signature x0) - | From.Parsetree.PTyp x0 -> - To.Parsetree.PTyp - (copy_core_type x0) - | From.Parsetree.PPat (x0,x1) -> - To.Parsetree.PPat - ((copy_pattern x0), - (copy_option copy_expression x1)) - -and copy_structure : - From.Parsetree.structure -> - To.Parsetree.structure - = fun x -> List.map copy_structure_item x - -and copy_structure_item : - From.Parsetree.structure_item -> - To.Parsetree.structure_item - = - fun - { From.Parsetree.pstr_desc = pstr_desc; - From.Parsetree.pstr_loc = pstr_loc } - -> - { - To.Parsetree.pstr_desc = - (copy_structure_item_desc pstr_desc); - To.Parsetree.pstr_loc = - (copy_location pstr_loc) - } - -and copy_structure_item_desc : - From.Parsetree.structure_item_desc -> - To.Parsetree.structure_item_desc - = - function - | From.Parsetree.Pstr_eval (x0,x1) -> - To.Parsetree.Pstr_eval - ((copy_expression x0), - (copy_attributes x1)) - | From.Parsetree.Pstr_value (x0,x1) -> - To.Parsetree.Pstr_value - ((copy_rec_flag x0), - (List.map copy_value_binding x1)) - | From.Parsetree.Pstr_primitive x0 -> - To.Parsetree.Pstr_primitive - (copy_value_description x0) - | From.Parsetree.Pstr_type (x0,x1) -> - To.Parsetree.Pstr_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Pstr_typext x0 -> - To.Parsetree.Pstr_typext - (copy_type_extension x0) - | From.Parsetree.Pstr_exception x0 -> - To.Parsetree.Pstr_exception - (copy_extension_constructor x0) - | From.Parsetree.Pstr_module x0 -> - To.Parsetree.Pstr_module - (copy_module_binding x0) - | From.Parsetree.Pstr_recmodule x0 -> - To.Parsetree.Pstr_recmodule - (List.map copy_module_binding x0) - | From.Parsetree.Pstr_modtype x0 -> - To.Parsetree.Pstr_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Pstr_open x0 -> - To.Parsetree.Pstr_open - (copy_open_description x0) - | From.Parsetree.Pstr_class x0 -> - To.Parsetree.Pstr_class - (List.map copy_class_declaration x0) - | From.Parsetree.Pstr_class_type x0 -> - To.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Pstr_include x0 -> - To.Parsetree.Pstr_include - (copy_include_declaration x0) - | From.Parsetree.Pstr_attribute x0 -> - To.Parsetree.Pstr_attribute - (copy_attribute x0) - | From.Parsetree.Pstr_extension (x0,x1) -> - To.Parsetree.Pstr_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_include_declaration : - From.Parsetree.include_declaration -> - To.Parsetree.include_declaration - = - fun x -> - copy_include_infos - copy_module_expr x - -and copy_class_declaration : - From.Parsetree.class_declaration -> - To.Parsetree.class_declaration - = - fun x -> - copy_class_infos - copy_class_expr x - -and copy_class_expr : - From.Parsetree.class_expr -> - To.Parsetree.class_expr - = - fun - { From.Parsetree.pcl_desc = pcl_desc; - From.Parsetree.pcl_loc = pcl_loc; - From.Parsetree.pcl_attributes = pcl_attributes } - -> - { - To.Parsetree.pcl_desc = - (copy_class_expr_desc pcl_desc); - To.Parsetree.pcl_loc = - (copy_location pcl_loc); - To.Parsetree.pcl_attributes = - (copy_attributes pcl_attributes) - } - -and copy_class_expr_desc : - From.Parsetree.class_expr_desc -> - To.Parsetree.class_expr_desc - = - function - | From.Parsetree.Pcl_constr (x0,x1) -> - To.Parsetree.Pcl_constr - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcl_structure x0 -> - To.Parsetree.Pcl_structure - (copy_class_structure x0) - | From.Parsetree.Pcl_fun (x0,x1,x2,x3) -> - To.Parsetree.Pcl_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_class_expr x3)) - | From.Parsetree.Pcl_apply (x0,x1) -> - To.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pcl_let (x0,x1,x2) -> - To.Parsetree.Pcl_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_class_expr x2)) - | From.Parsetree.Pcl_constraint (x0,x1) -> - To.Parsetree.Pcl_constraint - ((copy_class_expr x0), - (copy_class_type x1)) - | From.Parsetree.Pcl_extension x0 -> - To.Parsetree.Pcl_extension - (copy_extension x0) - -and copy_class_structure : - From.Parsetree.class_structure -> - To.Parsetree.class_structure - = - fun - { From.Parsetree.pcstr_self = pcstr_self; - From.Parsetree.pcstr_fields = pcstr_fields } - -> - { - To.Parsetree.pcstr_self = - (copy_pattern pcstr_self); - To.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } - -and copy_class_field : - From.Parsetree.class_field -> - To.Parsetree.class_field - = - fun - { From.Parsetree.pcf_desc = pcf_desc; - From.Parsetree.pcf_loc = pcf_loc; - From.Parsetree.pcf_attributes = pcf_attributes } - -> - { - To.Parsetree.pcf_desc = - (copy_class_field_desc pcf_desc); - To.Parsetree.pcf_loc = - (copy_location pcf_loc); - To.Parsetree.pcf_attributes = - (copy_attributes pcf_attributes) - } - -and copy_class_field_desc : - From.Parsetree.class_field_desc -> - To.Parsetree.class_field_desc - = - function - | From.Parsetree.Pcf_inherit (x0,x1,x2) -> - To.Parsetree.Pcf_inherit - ((copy_override_flag x0), - (copy_class_expr x1), - (copy_option (fun x -> x) x2)) - | From.Parsetree.Pcf_val x0 -> - To.Parsetree.Pcf_val - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_method x0 -> - To.Parsetree.Pcf_method - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_private_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_constraint x0 -> - To.Parsetree.Pcf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pcf_initializer x0 -> - To.Parsetree.Pcf_initializer - (copy_expression x0) - | From.Parsetree.Pcf_attribute x0 -> - To.Parsetree.Pcf_attribute - (copy_attribute x0) - | From.Parsetree.Pcf_extension x0 -> - To.Parsetree.Pcf_extension - (copy_extension x0) - -and copy_class_field_kind : - From.Parsetree.class_field_kind -> - To.Parsetree.class_field_kind - = - function - | From.Parsetree.Cfk_virtual x0 -> - To.Parsetree.Cfk_virtual - (copy_core_type x0) - | From.Parsetree.Cfk_concrete (x0,x1) -> - To.Parsetree.Cfk_concrete - ((copy_override_flag x0), - (copy_expression x1)) - -and copy_module_binding : - From.Parsetree.module_binding -> - To.Parsetree.module_binding - = - fun - { From.Parsetree.pmb_name = pmb_name; - From.Parsetree.pmb_expr = pmb_expr; - From.Parsetree.pmb_attributes = pmb_attributes; - From.Parsetree.pmb_loc = pmb_loc } - -> - { - To.Parsetree.pmb_name = - (copy_loc (fun x -> x) pmb_name); - To.Parsetree.pmb_expr = - (copy_module_expr pmb_expr); - To.Parsetree.pmb_attributes = - (copy_attributes pmb_attributes); - To.Parsetree.pmb_loc = - (copy_location pmb_loc) - } - -and copy_module_expr : - From.Parsetree.module_expr -> - To.Parsetree.module_expr - = - fun - { From.Parsetree.pmod_desc = pmod_desc; - From.Parsetree.pmod_loc = pmod_loc; - From.Parsetree.pmod_attributes = pmod_attributes } - -> - { - To.Parsetree.pmod_desc = - (copy_module_expr_desc pmod_desc); - To.Parsetree.pmod_loc = - (copy_location pmod_loc); - To.Parsetree.pmod_attributes = - (copy_attributes pmod_attributes) - } - -and copy_module_expr_desc : - From.Parsetree.module_expr_desc -> - To.Parsetree.module_expr_desc - = - function - | From.Parsetree.Pmod_ident x0 -> - To.Parsetree.Pmod_ident - (copy_loc copy_longident - x0) - | From.Parsetree.Pmod_structure x0 -> - To.Parsetree.Pmod_structure - (copy_structure x0) - | From.Parsetree.Pmod_functor (x0,x1,x2) -> - To.Parsetree.Pmod_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_expr x2)) - | From.Parsetree.Pmod_apply (x0,x1) -> - To.Parsetree.Pmod_apply - ((copy_module_expr x0), - (copy_module_expr x1)) - | From.Parsetree.Pmod_constraint (x0,x1) -> - To.Parsetree.Pmod_constraint - ((copy_module_expr x0), - (copy_module_type x1)) - | From.Parsetree.Pmod_unpack x0 -> - To.Parsetree.Pmod_unpack - (copy_expression x0) - | From.Parsetree.Pmod_extension x0 -> - To.Parsetree.Pmod_extension - (copy_extension x0) - -and copy_module_type : - From.Parsetree.module_type -> - To.Parsetree.module_type - = - fun - { From.Parsetree.pmty_desc = pmty_desc; - From.Parsetree.pmty_loc = pmty_loc; - From.Parsetree.pmty_attributes = pmty_attributes } - -> - { - To.Parsetree.pmty_desc = - (copy_module_type_desc pmty_desc); - To.Parsetree.pmty_loc = - (copy_location pmty_loc); - To.Parsetree.pmty_attributes = - (copy_attributes pmty_attributes) - } - -and copy_module_type_desc : - From.Parsetree.module_type_desc -> - To.Parsetree.module_type_desc - = - function - | From.Parsetree.Pmty_ident x0 -> - To.Parsetree.Pmty_ident - (copy_loc copy_longident - x0) - | From.Parsetree.Pmty_signature x0 -> - To.Parsetree.Pmty_signature - (copy_signature x0) - | From.Parsetree.Pmty_functor (x0,x1,x2) -> - To.Parsetree.Pmty_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_type x2)) - | From.Parsetree.Pmty_with (x0,x1) -> - To.Parsetree.Pmty_with - ((copy_module_type x0), - (List.map copy_with_constraint x1)) - | From.Parsetree.Pmty_typeof x0 -> - To.Parsetree.Pmty_typeof - (copy_module_expr x0) - | From.Parsetree.Pmty_extension x0 -> - To.Parsetree.Pmty_extension - (copy_extension x0) - | From.Parsetree.Pmty_alias x0 -> - To.Parsetree.Pmty_alias - (copy_loc copy_longident - x0) - -and copy_with_constraint : - From.Parsetree.with_constraint -> - To.Parsetree.with_constraint - = - function - | From.Parsetree.Pwith_type (x0,x1) -> - To.Parsetree.Pwith_type - ((copy_loc - copy_longident x0), - (copy_type_declaration x1)) - | From.Parsetree.Pwith_module (x0,x1) -> - To.Parsetree.Pwith_module - ((copy_loc - copy_longident x0), - (copy_loc - copy_longident x1)) - | From.Parsetree.Pwith_typesubst x0 -> - To.Parsetree.Pwith_typesubst - (copy_type_declaration x0) - | From.Parsetree.Pwith_modsubst (x0,x1) -> - To.Parsetree.Pwith_modsubst - ((copy_loc (fun x -> x) x0), - (copy_loc - copy_longident x1)) - -and copy_signature : - From.Parsetree.signature -> - To.Parsetree.signature - = fun x -> List.map copy_signature_item x - -and copy_signature_item : - From.Parsetree.signature_item -> - To.Parsetree.signature_item - = - fun - { From.Parsetree.psig_desc = psig_desc; - From.Parsetree.psig_loc = psig_loc } - -> - { - To.Parsetree.psig_desc = - (copy_signature_item_desc psig_desc); - To.Parsetree.psig_loc = - (copy_location psig_loc) - } - -and copy_signature_item_desc : - From.Parsetree.signature_item_desc -> - To.Parsetree.signature_item_desc - = - function - | From.Parsetree.Psig_value x0 -> - To.Parsetree.Psig_value - (copy_value_description x0) - | From.Parsetree.Psig_type (x0,x1) -> - To.Parsetree.Psig_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Psig_typext x0 -> - To.Parsetree.Psig_typext - (copy_type_extension x0) - | From.Parsetree.Psig_exception x0 -> - To.Parsetree.Psig_exception - (copy_extension_constructor x0) - | From.Parsetree.Psig_module x0 -> - To.Parsetree.Psig_module - (copy_module_declaration x0) - | From.Parsetree.Psig_recmodule x0 -> - To.Parsetree.Psig_recmodule - (List.map copy_module_declaration x0) - | From.Parsetree.Psig_modtype x0 -> - To.Parsetree.Psig_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Psig_open x0 -> - To.Parsetree.Psig_open - (copy_open_description x0) - | From.Parsetree.Psig_include x0 -> - To.Parsetree.Psig_include - (copy_include_description x0) - | From.Parsetree.Psig_class x0 -> - To.Parsetree.Psig_class - (List.map copy_class_description x0) - | From.Parsetree.Psig_class_type x0 -> - To.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Psig_attribute x0 -> - To.Parsetree.Psig_attribute - (copy_attribute x0) - | From.Parsetree.Psig_extension (x0,x1) -> - To.Parsetree.Psig_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_class_type_declaration : - From.Parsetree.class_type_declaration -> - To.Parsetree.class_type_declaration - = - fun x -> - copy_class_infos - copy_class_type x - -and copy_class_description : - From.Parsetree.class_description -> - To.Parsetree.class_description - = - fun x -> - copy_class_infos - copy_class_type x - -and copy_class_type : - From.Parsetree.class_type -> - To.Parsetree.class_type - = - fun - { From.Parsetree.pcty_desc = pcty_desc; - From.Parsetree.pcty_loc = pcty_loc; - From.Parsetree.pcty_attributes = pcty_attributes } - -> - { - To.Parsetree.pcty_desc = - (copy_class_type_desc pcty_desc); - To.Parsetree.pcty_loc = - (copy_location pcty_loc); - To.Parsetree.pcty_attributes = - (copy_attributes pcty_attributes) - } - -and copy_class_type_desc : - From.Parsetree.class_type_desc -> - To.Parsetree.class_type_desc - = - function - | From.Parsetree.Pcty_constr (x0,x1) -> - To.Parsetree.Pcty_constr - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcty_signature x0 -> - To.Parsetree.Pcty_signature - (copy_class_signature x0) - | From.Parsetree.Pcty_arrow (x0,x1,x2) -> - To.Parsetree.Pcty_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_class_type x2)) - | From.Parsetree.Pcty_extension x0 -> - To.Parsetree.Pcty_extension - (copy_extension x0) - -and copy_class_signature : - From.Parsetree.class_signature -> - To.Parsetree.class_signature - = - fun - { From.Parsetree.pcsig_self = pcsig_self; - From.Parsetree.pcsig_fields = pcsig_fields } - -> - { - To.Parsetree.pcsig_self = - (copy_core_type pcsig_self); - To.Parsetree.pcsig_fields = - (List.map copy_class_type_field - pcsig_fields) - } - -and copy_class_type_field : - From.Parsetree.class_type_field -> - To.Parsetree.class_type_field - = - fun - { From.Parsetree.pctf_desc = pctf_desc; - From.Parsetree.pctf_loc = pctf_loc; - From.Parsetree.pctf_attributes = pctf_attributes } - -> - { - To.Parsetree.pctf_desc = - (copy_class_type_field_desc pctf_desc); - To.Parsetree.pctf_loc = - (copy_location pctf_loc); - To.Parsetree.pctf_attributes = - (copy_attributes pctf_attributes) - } - -and copy_class_type_field_desc : - From.Parsetree.class_type_field_desc -> - To.Parsetree.class_type_field_desc - = - function - | From.Parsetree.Pctf_inherit x0 -> - To.Parsetree.Pctf_inherit - (copy_class_type x0) - | From.Parsetree.Pctf_val x0 -> - To.Parsetree.Pctf_val - (let (x0,x1,x2,x3) = x0 in - (x0, (copy_mutable_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_method x0 -> - To.Parsetree.Pctf_method - (let (x0,x1,x2,x3) = x0 in - (x0, (copy_private_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_constraint x0 -> - To.Parsetree.Pctf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pctf_attribute x0 -> - To.Parsetree.Pctf_attribute - (copy_attribute x0) - | From.Parsetree.Pctf_extension x0 -> - To.Parsetree.Pctf_extension - (copy_extension x0) - -and copy_extension : - From.Parsetree.extension -> - To.Parsetree.extension - = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.class_infos -> - 'g0 To.Parsetree.class_infos - = - fun f0 -> - fun - { From.Parsetree.pci_virt = pci_virt; - From.Parsetree.pci_params = pci_params; - From.Parsetree.pci_name = pci_name; - From.Parsetree.pci_expr = pci_expr; - From.Parsetree.pci_loc = pci_loc; - From.Parsetree.pci_attributes = pci_attributes } - -> - { - To.Parsetree.pci_virt = - (copy_virtual_flag pci_virt); - To.Parsetree.pci_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) pci_params); - To.Parsetree.pci_name = - (copy_loc (fun x -> x) pci_name); - To.Parsetree.pci_expr = (f0 pci_expr); - To.Parsetree.pci_loc = - (copy_location pci_loc); - To.Parsetree.pci_attributes = - (copy_attributes pci_attributes) - } - -and copy_virtual_flag : - From.Asttypes.virtual_flag -> - To.Asttypes.virtual_flag - = - function - | From.Asttypes.Virtual -> To.Asttypes.Virtual - | From.Asttypes.Concrete -> To.Asttypes.Concrete - -and copy_include_description : - From.Parsetree.include_description -> - To.Parsetree.include_description - = - fun x -> - copy_include_infos - copy_module_type x - -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.include_infos -> - 'g0 To.Parsetree.include_infos - = - fun f0 -> - fun - { From.Parsetree.pincl_mod = pincl_mod; - From.Parsetree.pincl_loc = pincl_loc; - From.Parsetree.pincl_attributes = pincl_attributes } - -> - { - To.Parsetree.pincl_mod = (f0 pincl_mod); - To.Parsetree.pincl_loc = - (copy_location pincl_loc); - To.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } - -and copy_open_description : - From.Parsetree.open_description -> - To.Parsetree.open_description - = - fun - { From.Parsetree.popen_lid = popen_lid; - From.Parsetree.popen_override = popen_override; - From.Parsetree.popen_loc = popen_loc; - From.Parsetree.popen_attributes = popen_attributes } - -> - { - To.Parsetree.popen_lid = - (copy_loc copy_longident - popen_lid); - To.Parsetree.popen_override = - (copy_override_flag popen_override); - To.Parsetree.popen_loc = - (copy_location popen_loc); - To.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } - -and copy_override_flag : - From.Asttypes.override_flag -> - To.Asttypes.override_flag - = - function - | From.Asttypes.Override -> To.Asttypes.Override - | From.Asttypes.Fresh -> To.Asttypes.Fresh - -and copy_module_type_declaration : - From.Parsetree.module_type_declaration -> - To.Parsetree.module_type_declaration - = - fun - { From.Parsetree.pmtd_name = pmtd_name; - From.Parsetree.pmtd_type = pmtd_type; - From.Parsetree.pmtd_attributes = pmtd_attributes; - From.Parsetree.pmtd_loc = pmtd_loc } - -> - { - To.Parsetree.pmtd_name = - (copy_loc (fun x -> x) pmtd_name); - To.Parsetree.pmtd_type = - (copy_option copy_module_type pmtd_type); - To.Parsetree.pmtd_attributes = - (copy_attributes pmtd_attributes); - To.Parsetree.pmtd_loc = - (copy_location pmtd_loc) - } - -and copy_module_declaration : - From.Parsetree.module_declaration -> - To.Parsetree.module_declaration - = - fun - { From.Parsetree.pmd_name = pmd_name; - From.Parsetree.pmd_type = pmd_type; - From.Parsetree.pmd_attributes = pmd_attributes; - From.Parsetree.pmd_loc = pmd_loc } - -> - { - To.Parsetree.pmd_name = - (copy_loc (fun x -> x) pmd_name); - To.Parsetree.pmd_type = - (copy_module_type pmd_type); - To.Parsetree.pmd_attributes = - (copy_attributes pmd_attributes); - To.Parsetree.pmd_loc = - (copy_location pmd_loc) - } - -and copy_type_extension : - From.Parsetree.type_extension -> - To.Parsetree.type_extension - = - fun - { From.Parsetree.ptyext_path = ptyext_path; - From.Parsetree.ptyext_params = ptyext_params; - From.Parsetree.ptyext_constructors = ptyext_constructors; - From.Parsetree.ptyext_private = ptyext_private; - From.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - To.Parsetree.ptyext_path = - (copy_loc copy_longident - ptyext_path); - To.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptyext_params); - To.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor - ptyext_constructors); - To.Parsetree.ptyext_private = - (copy_private_flag ptyext_private); - To.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } - -and copy_extension_constructor : - From.Parsetree.extension_constructor -> - To.Parsetree.extension_constructor - = - fun - { From.Parsetree.pext_name = pext_name; - From.Parsetree.pext_kind = pext_kind; - From.Parsetree.pext_loc = pext_loc; - From.Parsetree.pext_attributes = pext_attributes } - -> - { - To.Parsetree.pext_name = - (copy_loc (fun x -> x) pext_name); - To.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - To.Parsetree.pext_loc = - (copy_location pext_loc); - To.Parsetree.pext_attributes = - (copy_attributes pext_attributes) - } - -and copy_extension_constructor_kind : - From.Parsetree.extension_constructor_kind -> - To.Parsetree.extension_constructor_kind - = - function - | From.Parsetree.Pext_decl (x0,x1) -> - To.Parsetree.Pext_decl - ((copy_constructor_arguments x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pext_rebind x0 -> - To.Parsetree.Pext_rebind - (copy_loc copy_longident - x0) - -and copy_type_declaration : - From.Parsetree.type_declaration -> - To.Parsetree.type_declaration - = - fun - { From.Parsetree.ptype_name = ptype_name; - From.Parsetree.ptype_params = ptype_params; - From.Parsetree.ptype_cstrs = ptype_cstrs; - From.Parsetree.ptype_kind = ptype_kind; - From.Parsetree.ptype_private = ptype_private; - From.Parsetree.ptype_manifest = ptype_manifest; - From.Parsetree.ptype_attributes = ptype_attributes; - From.Parsetree.ptype_loc = ptype_loc } - -> - { - To.Parsetree.ptype_name = - (copy_loc (fun x -> x) ptype_name); - To.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptype_params); - To.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0,x1,x2) = x in - ((copy_core_type x0), - (copy_core_type x1), - (copy_location x2))) ptype_cstrs); - To.Parsetree.ptype_kind = - (copy_type_kind ptype_kind); - To.Parsetree.ptype_private = - (copy_private_flag ptype_private); - To.Parsetree.ptype_manifest = - (copy_option copy_core_type ptype_manifest); - To.Parsetree.ptype_attributes = - (copy_attributes ptype_attributes); - To.Parsetree.ptype_loc = - (copy_location ptype_loc) - } - -and copy_private_flag : - From.Asttypes.private_flag -> - To.Asttypes.private_flag - = - function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - -and copy_type_kind : - From.Parsetree.type_kind -> - To.Parsetree.type_kind - = - function - | From.Parsetree.Ptype_abstract -> - To.Parsetree.Ptype_abstract - | From.Parsetree.Ptype_variant x0 -> - To.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | From.Parsetree.Ptype_record x0 -> - To.Parsetree.Ptype_record - (List.map copy_label_declaration x0) - | From.Parsetree.Ptype_open -> - To.Parsetree.Ptype_open - -and copy_constructor_declaration : - From.Parsetree.constructor_declaration -> - To.Parsetree.constructor_declaration - = - fun - { From.Parsetree.pcd_name = pcd_name; - From.Parsetree.pcd_args = pcd_args; - From.Parsetree.pcd_res = pcd_res; - From.Parsetree.pcd_loc = pcd_loc; - From.Parsetree.pcd_attributes = pcd_attributes } - -> - { - To.Parsetree.pcd_name = - (copy_loc (fun x -> x) pcd_name); - To.Parsetree.pcd_args = - (copy_constructor_arguments pcd_args); - To.Parsetree.pcd_res = - (copy_option copy_core_type pcd_res); - To.Parsetree.pcd_loc = - (copy_location pcd_loc); - To.Parsetree.pcd_attributes = - (copy_attributes pcd_attributes) - } - -and copy_constructor_arguments : - From.Parsetree.constructor_arguments -> - To.Parsetree.constructor_arguments - = - function - | From.Parsetree.Pcstr_tuple x0 -> - To.Parsetree.Pcstr_tuple - (List.map copy_core_type x0) - | From.Parsetree.Pcstr_record x0 -> - To.Parsetree.Pcstr_record - (List.map copy_label_declaration x0) - -and copy_label_declaration : - From.Parsetree.label_declaration -> - To.Parsetree.label_declaration - = - fun - { From.Parsetree.pld_name = pld_name; - From.Parsetree.pld_mutable = pld_mutable; - From.Parsetree.pld_type = pld_type; - From.Parsetree.pld_loc = pld_loc; - From.Parsetree.pld_attributes = pld_attributes } - -> - { - To.Parsetree.pld_name = - (copy_loc (fun x -> x) pld_name); - To.Parsetree.pld_mutable = - (copy_mutable_flag pld_mutable); - To.Parsetree.pld_type = - (copy_core_type pld_type); - To.Parsetree.pld_loc = - (copy_location pld_loc); - To.Parsetree.pld_attributes = - (copy_attributes pld_attributes) - } - -and copy_mutable_flag : - From.Asttypes.mutable_flag -> - To.Asttypes.mutable_flag - = - function - | From.Asttypes.Immutable -> - To.Asttypes.Immutable - | From.Asttypes.Mutable -> To.Asttypes.Mutable - -and copy_variance : - From.Asttypes.variance -> To.Asttypes.variance = - function - | From.Asttypes.Covariant -> - To.Asttypes.Covariant - | From.Asttypes.Contravariant -> - To.Asttypes.Contravariant - | From.Asttypes.Invariant -> - To.Asttypes.Invariant - -and copy_value_description : - From.Parsetree.value_description -> - To.Parsetree.value_description - = - fun - { From.Parsetree.pval_name = pval_name; - From.Parsetree.pval_type = pval_type; - From.Parsetree.pval_prim = pval_prim; - From.Parsetree.pval_attributes = pval_attributes; - From.Parsetree.pval_loc = pval_loc } - -> - { - To.Parsetree.pval_name = - (copy_loc (fun x -> x) pval_name); - To.Parsetree.pval_type = - (copy_core_type pval_type); - To.Parsetree.pval_prim = - (List.map (fun x -> x) pval_prim); - To.Parsetree.pval_attributes = - (copy_attributes pval_attributes); - To.Parsetree.pval_loc = - (copy_location pval_loc) - } - -and copy_arg_label : - From.Asttypes.arg_label -> To.Asttypes.arg_label - = - function - | From.Asttypes.Nolabel -> To.Asttypes.Nolabel - | From.Asttypes.Labelled x0 -> - To.Asttypes.Labelled x0 - | From.Asttypes.Optional x0 -> - To.Asttypes.Optional x0 - -and copy_closed_flag : - From.Asttypes.closed_flag -> - To.Asttypes.closed_flag - = - function - | From.Asttypes.Closed -> To.Asttypes.Closed - | From.Asttypes.Open -> To.Asttypes.Open - -and copy_label : - From.Asttypes.label -> To.Asttypes.label = - fun x -> x - -and copy_rec_flag : - From.Asttypes.rec_flag -> To.Asttypes.rec_flag = - function - | From.Asttypes.Nonrecursive -> - To.Asttypes.Nonrecursive - | From.Asttypes.Recursive -> - To.Asttypes.Recursive - -and copy_constant : - From.Parsetree.constant -> To.Parsetree.constant - = - function - | From.Parsetree.Pconst_integer (x0,x1) -> - To.Parsetree.Pconst_integer - (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_char x0 -> - To.Parsetree.Pconst_char x0 - | From.Parsetree.Pconst_string (x0,x1) -> - To.Parsetree.Pconst_string - (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_float (x0,x1) -> - To.Parsetree.Pconst_float - (x0, (copy_option (fun x -> x) x1)) - -and copy_option : 'f0 'g0 . ('f0 -> 'g0) -> 'f0 option -> 'g0 option = - fun f0 -> function | None -> None | Some x0 -> Some (f0 x0) - -and copy_longident : - From.Longident.t -> To.Longident.t = - function - | From.Longident.Lident x0 -> - To.Longident.Lident x0 - | From.Longident.Ldot (x0,x1) -> - To.Longident.Ldot - ((copy_longident x0), x1) - | From.Longident.Lapply (x0,x1) -> - To.Longident.Lapply - ((copy_longident x0), (copy_longident x1)) - -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc - = - fun f0 -> - fun - { From.Asttypes.txt = txt; - From.Asttypes.loc = loc } - -> - { - To.Asttypes.txt = (f0 txt); - To.Asttypes.loc = (copy_location loc) - } - -and copy_location : - From.Location.t -> To.Location.t = - fun - { From.Location.loc_start = loc_start; - From.Location.loc_end = loc_end; - From.Location.loc_ghost = loc_ghost } - -> - { - To.Location.loc_start = (copy_Lexing_position loc_start); - To.Location.loc_end = (copy_Lexing_position loc_end); - To.Location.loc_ghost = (copy_bool loc_ghost) - } - -and copy_bool : bool -> bool = function | false -> false | true -> true - -and copy_Lexing_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum + (fun x -> + let (x0, x1, x2) = x in + (x0, (List.map copy_out_type x1), + (Option.map copy_out_type x2))) otyext_constructors); + Ast_404.Outcometree.otyext_private = (copy_private_flag otyext_private) } - -let rec copy_out_phrase : - From.Outcometree.out_phrase -> To.Outcometree.out_phrase = +and copy_out_phrase : + Ast_403.Outcometree.out_phrase -> Ast_404.Outcometree.out_phrase = function - | From.Outcometree.Ophr_eval (x0,x1) -> - To.Outcometree.Ophr_eval - ((copy_out_value x0), - (copy_out_type x1)) - | From.Outcometree.Ophr_signature x0 -> - To.Outcometree.Ophr_signature + | Ast_403.Outcometree.Ophr_eval (x0, x1) -> + Ast_404.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1)) + | Ast_403.Outcometree.Ophr_signature x0 -> + Ast_404.Outcometree.Ophr_signature (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_sig_item x0), - (copy_option copy_out_value x1))) x0) - | From.Outcometree.Ophr_exception x0 -> - To.Outcometree.Ophr_exception - (let (x0,x1) = x0 in - ((copy_exn x0), (copy_out_value x1))) - -and copy_exn : exn -> exn = fun x -> x - + (fun x -> + let (x0, x1) = x in + ((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0) + | Ast_403.Outcometree.Ophr_exception x0 -> + Ast_404.Outcometree.Ophr_exception + (let (x0, x1) = x0 in (x0, (copy_out_value x1))) and copy_out_sig_item : - From.Outcometree.out_sig_item -> To.Outcometree.out_sig_item = + Ast_403.Outcometree.out_sig_item -> Ast_404.Outcometree.out_sig_item = function - | From.Outcometree.Osig_class (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class - ((copy_bool x0), x1, + | Ast_403.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> + Ast_404.Outcometree.Osig_class + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_class_type (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class_type - ((copy_bool x0), x1, + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_403.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> + Ast_404.Outcometree.Osig_class_type + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_typext (x0,x1) -> - To.Outcometree.Osig_typext - ((copy_out_extension_constructor x0), - (copy_out_ext_status x1)) - | From.Outcometree.Osig_modtype (x0,x1) -> - To.Outcometree.Osig_modtype - (x0, (copy_out_module_type x1)) - | From.Outcometree.Osig_module (x0,x1,x2) -> - To.Outcometree.Osig_module - (x0, (copy_out_module_type x1), - (copy_out_rec_status x2)) - | From.Outcometree.Osig_type (x0,x1) -> - To.Outcometree.Osig_type - ((copy_out_type_decl x0), - (copy_out_rec_status x1)) - | From.Outcometree.Osig_value x0 -> - To.Outcometree.Osig_value - (copy_out_val_decl x0) - | From.Outcometree.Osig_ellipsis -> To.Outcometree.Osig_ellipsis - + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_403.Outcometree.Osig_typext (x0, x1) -> + Ast_404.Outcometree.Osig_typext + ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) + | Ast_403.Outcometree.Osig_modtype (x0, x1) -> + Ast_404.Outcometree.Osig_modtype (x0, (copy_out_module_type x1)) + | Ast_403.Outcometree.Osig_module (x0, x1, x2) -> + Ast_404.Outcometree.Osig_module + (x0, (copy_out_module_type x1), (copy_out_rec_status x2)) + | Ast_403.Outcometree.Osig_type (x0, x1) -> + Ast_404.Outcometree.Osig_type + ((copy_out_type_decl x0), (copy_out_rec_status x1)) + | Ast_403.Outcometree.Osig_value x0 -> + Ast_404.Outcometree.Osig_value (copy_out_val_decl x0) + | Ast_403.Outcometree.Osig_ellipsis -> Ast_404.Outcometree.Osig_ellipsis and copy_out_val_decl : - From.Outcometree.out_val_decl -> To.Outcometree.out_val_decl = + Ast_403.Outcometree.out_val_decl -> Ast_404.Outcometree.out_val_decl = fun - { From.Outcometree.oval_name = oval_name; - From.Outcometree.oval_type = oval_type; - From.Outcometree.oval_prims = oval_prims; - From.Outcometree.oval_attributes = oval_attributes } - -> + { Ast_403.Outcometree.oval_name = oval_name; + Ast_403.Outcometree.oval_type = oval_type; + Ast_403.Outcometree.oval_prims = oval_prims; + Ast_403.Outcometree.oval_attributes = oval_attributes } + -> { - To.Outcometree.oval_name = oval_name; - To.Outcometree.oval_type = - (copy_out_type oval_type); - To.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); - To.Outcometree.oval_attributes = + Ast_404.Outcometree.oval_name = oval_name; + Ast_404.Outcometree.oval_type = (copy_out_type oval_type); + Ast_404.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); + Ast_404.Outcometree.oval_attributes = (List.map copy_out_attribute oval_attributes) } +and copy_From_Asttypes_private_flag : + From.Asttypes.private_flag -> To.Asttypes.private_flag = + function + | From.Asttypes.Private -> To.Asttypes.Private + | From.Asttypes.Public -> To.Asttypes.Public + and copy_out_type_decl : From.Outcometree.out_type_decl -> To.Outcometree.out_type_decl = fun @@ -1607,13 +106,13 @@ and copy_out_type_decl : (List.map (fun x -> let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) + (x0, (let (x0,x1) = x1 in (x0, x1)))) otype_params); To.Outcometree.otype_type = (copy_out_type otype_type); To.Outcometree.otype_private = (copy_From_Asttypes_private_flag otype_private); - To.Outcometree.otype_immediate = (copy_bool otype_immediate); + To.Outcometree.otype_immediate = otype_immediate; To.Outcometree.otype_unboxed = false; To.Outcometree.otype_cstrs = (List.map @@ -1622,286 +121,190 @@ and copy_out_type_decl : ((copy_out_type x0), (copy_out_type x1))) otype_cstrs) } - and copy_out_module_type : - From.Outcometree.out_module_type -> To.Outcometree.out_module_type - = - function - | From.Outcometree.Omty_abstract -> To.Outcometree.Omty_abstract - | From.Outcometree.Omty_functor (x0,x1,x2) -> - To.Outcometree.Omty_functor - (x0, (copy_option copy_out_module_type x1), - (copy_out_module_type x2)) - | From.Outcometree.Omty_ident x0 -> - To.Outcometree.Omty_ident (copy_out_ident x0) - | From.Outcometree.Omty_signature x0 -> - To.Outcometree.Omty_signature - (List.map copy_out_sig_item x0) - | From.Outcometree.Omty_alias x0 -> - To.Outcometree.Omty_alias (copy_out_ident x0) - + Ast_403.Outcometree.out_module_type -> Ast_404.Outcometree.out_module_type + = + function + | Ast_403.Outcometree.Omty_abstract -> Ast_404.Outcometree.Omty_abstract + | Ast_403.Outcometree.Omty_functor (x0, x1, x2) -> + Ast_404.Outcometree.Omty_functor + (x0, (Option.map copy_out_module_type x1), (copy_out_module_type x2)) + | Ast_403.Outcometree.Omty_ident x0 -> + Ast_404.Outcometree.Omty_ident (copy_out_ident x0) + | Ast_403.Outcometree.Omty_signature x0 -> + Ast_404.Outcometree.Omty_signature (List.map copy_out_sig_item x0) + | Ast_403.Outcometree.Omty_alias x0 -> + Ast_404.Outcometree.Omty_alias (copy_out_ident x0) and copy_out_ext_status : - From.Outcometree.out_ext_status -> To.Outcometree.out_ext_status = + Ast_403.Outcometree.out_ext_status -> Ast_404.Outcometree.out_ext_status = function - | From.Outcometree.Oext_first -> To.Outcometree.Oext_first - | From.Outcometree.Oext_next -> To.Outcometree.Oext_next - | From.Outcometree.Oext_exception -> To.Outcometree.Oext_exception - + | Ast_403.Outcometree.Oext_first -> Ast_404.Outcometree.Oext_first + | Ast_403.Outcometree.Oext_next -> Ast_404.Outcometree.Oext_next + | Ast_403.Outcometree.Oext_exception -> Ast_404.Outcometree.Oext_exception and copy_out_extension_constructor : - From.Outcometree.out_extension_constructor -> - To.Outcometree.out_extension_constructor + Ast_403.Outcometree.out_extension_constructor -> + Ast_404.Outcometree.out_extension_constructor = fun - { From.Outcometree.oext_name = oext_name; - From.Outcometree.oext_type_name = oext_type_name; - From.Outcometree.oext_type_params = oext_type_params; - From.Outcometree.oext_args = oext_args; - From.Outcometree.oext_ret_type = oext_ret_type; - From.Outcometree.oext_private = oext_private } - -> + { Ast_403.Outcometree.oext_name = oext_name; + Ast_403.Outcometree.oext_type_name = oext_type_name; + Ast_403.Outcometree.oext_type_params = oext_type_params; + Ast_403.Outcometree.oext_args = oext_args; + Ast_403.Outcometree.oext_ret_type = oext_ret_type; + Ast_403.Outcometree.oext_private = oext_private } + -> { - To.Outcometree.oext_name = oext_name; - To.Outcometree.oext_type_name = oext_type_name; - To.Outcometree.oext_type_params = - (List.map (fun x -> x) oext_type_params); - To.Outcometree.oext_args = - (List.map copy_out_type oext_args); - To.Outcometree.oext_ret_type = - (copy_option copy_out_type oext_ret_type); - To.Outcometree.oext_private = - (copy_From_Asttypes_private_flag oext_private) + Ast_404.Outcometree.oext_name = oext_name; + Ast_404.Outcometree.oext_type_name = oext_type_name; + Ast_404.Outcometree.oext_type_params = + (List.map (fun x -> x) oext_type_params); + Ast_404.Outcometree.oext_args = (List.map copy_out_type oext_args); + Ast_404.Outcometree.oext_ret_type = + (Option.map copy_out_type oext_ret_type); + Ast_404.Outcometree.oext_private = (copy_private_flag oext_private) } - -and copy_From_Asttypes_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = +and copy_private_flag : + Ast_403.Asttypes.private_flag -> Ast_404.Asttypes.private_flag = function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - + | Ast_403.Asttypes.Private -> Ast_404.Asttypes.Private + | Ast_403.Asttypes.Public -> Ast_404.Asttypes.Public and copy_out_rec_status : - From.Outcometree.out_rec_status -> To.Outcometree.out_rec_status = + Ast_403.Outcometree.out_rec_status -> Ast_404.Outcometree.out_rec_status = function - | From.Outcometree.Orec_not -> To.Outcometree.Orec_not - | From.Outcometree.Orec_first -> To.Outcometree.Orec_first - | From.Outcometree.Orec_next -> To.Outcometree.Orec_next - + | Ast_403.Outcometree.Orec_not -> Ast_404.Outcometree.Orec_not + | Ast_403.Outcometree.Orec_first -> Ast_404.Outcometree.Orec_first + | Ast_403.Outcometree.Orec_next -> Ast_404.Outcometree.Orec_next and copy_out_class_type : - From.Outcometree.out_class_type -> To.Outcometree.out_class_type = - function - | From.Outcometree.Octy_constr (x0,x1) -> - To.Outcometree.Octy_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Octy_arrow (x0,x1,x2) -> - To.Outcometree.Octy_arrow - (x0, (copy_out_type x1), - (copy_out_class_type x2)) - | From.Outcometree.Octy_signature (x0,x1) -> - To.Outcometree.Octy_signature - ((copy_option copy_out_type x0), + Ast_403.Outcometree.out_class_type -> Ast_404.Outcometree.out_class_type = + function + | Ast_403.Outcometree.Octy_constr (x0, x1) -> + Ast_404.Outcometree.Octy_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_403.Outcometree.Octy_arrow (x0, x1, x2) -> + Ast_404.Outcometree.Octy_arrow + (x0, (copy_out_type x1), (copy_out_class_type x2)) + | Ast_403.Outcometree.Octy_signature (x0, x1) -> + Ast_404.Outcometree.Octy_signature + ((Option.map copy_out_type x0), (List.map copy_out_class_sig_item x1)) - and copy_out_class_sig_item : - From.Outcometree.out_class_sig_item -> - To.Outcometree.out_class_sig_item + Ast_403.Outcometree.out_class_sig_item -> + Ast_404.Outcometree.out_class_sig_item = function - | From.Outcometree.Ocsg_constraint (x0,x1) -> - To.Outcometree.Ocsg_constraint - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Ocsg_method (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_method - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - | From.Outcometree.Ocsg_value (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_value - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - + | Ast_403.Outcometree.Ocsg_constraint (x0, x1) -> + Ast_404.Outcometree.Ocsg_constraint + ((copy_out_type x0), (copy_out_type x1)) + | Ast_403.Outcometree.Ocsg_method (x0, x1, x2, x3) -> + Ast_404.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3)) + | Ast_403.Outcometree.Ocsg_value (x0, x1, x2, x3) -> + Ast_404.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3)) and copy_out_type : - From.Outcometree.out_type -> To.Outcometree.out_type = - function - | From.Outcometree.Otyp_abstract -> To.Outcometree.Otyp_abstract - | From.Outcometree.Otyp_open -> To.Outcometree.Otyp_open - | From.Outcometree.Otyp_alias (x0,x1) -> - To.Outcometree.Otyp_alias - ((copy_out_type x0), x1) - | From.Outcometree.Otyp_arrow (x0,x1,x2) -> - To.Outcometree.Otyp_arrow - (x0, (copy_out_type x1), - (copy_out_type x2)) - | From.Outcometree.Otyp_class (x0,x1,x2) -> - To.Outcometree.Otyp_class - ((copy_bool x0), (copy_out_ident x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_constr (x0,x1) -> - To.Outcometree.Otyp_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Otyp_manifest (x0,x1) -> - To.Outcometree.Otyp_manifest - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Otyp_object (x0,x1) -> - To.Outcometree.Otyp_object - ((List.map - (fun x -> - let (x0,x1) = x in - (x0, (copy_out_type x1))) x0), - (copy_option copy_bool x1)) - | From.Outcometree.Otyp_record x0 -> - To.Outcometree.Otyp_record + Ast_403.Outcometree.out_type -> Ast_404.Outcometree.out_type = + function + | Ast_403.Outcometree.Otyp_abstract -> Ast_404.Outcometree.Otyp_abstract + | Ast_403.Outcometree.Otyp_open -> Ast_404.Outcometree.Otyp_open + | Ast_403.Outcometree.Otyp_alias (x0, x1) -> + Ast_404.Outcometree.Otyp_alias ((copy_out_type x0), x1) + | Ast_403.Outcometree.Otyp_arrow (x0, x1, x2) -> + Ast_404.Outcometree.Otyp_arrow + (x0, (copy_out_type x1), (copy_out_type x2)) + | Ast_403.Outcometree.Otyp_class (x0, x1, x2) -> + Ast_404.Outcometree.Otyp_class + (x0, (copy_out_ident x1), (List.map copy_out_type x2)) + | Ast_403.Outcometree.Otyp_constr (x0, x1) -> + Ast_404.Outcometree.Otyp_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_403.Outcometree.Otyp_manifest (x0, x1) -> + Ast_404.Outcometree.Otyp_manifest + ((copy_out_type x0), (copy_out_type x1)) + | Ast_403.Outcometree.Otyp_object (x0, x1) -> + Ast_404.Outcometree.Otyp_object + ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0), + (Option.map (fun x -> x) x1)) + | Ast_403.Outcometree.Otyp_record x0 -> + Ast_404.Outcometree.Otyp_record (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), (copy_out_type x2))) - x0) - | From.Outcometree.Otyp_stuff x0 -> To.Outcometree.Otyp_stuff x0 - | From.Outcometree.Otyp_sum x0 -> - To.Outcometree.Otyp_sum + (fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0) + | Ast_403.Outcometree.Otyp_stuff x0 -> Ast_404.Outcometree.Otyp_stuff x0 + | Ast_403.Outcometree.Otyp_sum x0 -> + Ast_404.Outcometree.Otyp_sum (List.map - (fun x -> - let (x0,x1,x2) = x in + (fun x -> + let (x0, x1, x2) = x in (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) x0) - | From.Outcometree.Otyp_tuple x0 -> - To.Outcometree.Otyp_tuple - (List.map copy_out_type x0) - | From.Outcometree.Otyp_var (x0,x1) -> - To.Outcometree.Otyp_var ((copy_bool x0), x1) - | From.Outcometree.Otyp_variant (x0,x1,x2,x3) -> - To.Outcometree.Otyp_variant - ((copy_bool x0), (copy_out_variant x1), - (copy_bool x2), - (copy_option (fun x -> List.map (fun x -> x) x) x3)) - | From.Outcometree.Otyp_poly (x0,x1) -> - To.Outcometree.Otyp_poly - ((List.map (fun x -> x) x0), (copy_out_type x1)) - | From.Outcometree.Otyp_module (x0,x1,x2) -> - To.Outcometree.Otyp_module - (x0, (List.map (fun x -> x) x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_attribute (x0,x1) -> - To.Outcometree.Otyp_attribute - ((copy_out_type x0), - (copy_out_attribute x1)) - + (Option.map copy_out_type x2))) x0) + | Ast_403.Outcometree.Otyp_tuple x0 -> + Ast_404.Outcometree.Otyp_tuple (List.map copy_out_type x0) + | Ast_403.Outcometree.Otyp_var (x0, x1) -> + Ast_404.Outcometree.Otyp_var (x0, x1) + | Ast_403.Outcometree.Otyp_variant (x0, x1, x2, x3) -> + Ast_404.Outcometree.Otyp_variant + (x0, (copy_out_variant x1), x2, + (Option.map (fun x -> List.map (fun x -> x) x) x3)) + | Ast_403.Outcometree.Otyp_poly (x0, x1) -> + Ast_404.Outcometree.Otyp_poly + ((List.map (fun x -> x) x0), (copy_out_type x1)) + | Ast_403.Outcometree.Otyp_module (x0, x1, x2) -> + Ast_404.Outcometree.Otyp_module + (x0, (List.map (fun x -> x) x1), (List.map copy_out_type x2)) + | Ast_403.Outcometree.Otyp_attribute (x0, x1) -> + Ast_404.Outcometree.Otyp_attribute + ((copy_out_type x0), (copy_out_attribute x1)) and copy_out_attribute : - From.Outcometree.out_attribute -> To.Outcometree.out_attribute = - fun { From.Outcometree.oattr_name = oattr_name } -> - { To.Outcometree.oattr_name = oattr_name } - + Ast_403.Outcometree.out_attribute -> Ast_404.Outcometree.out_attribute = + fun { Ast_403.Outcometree.oattr_name = oattr_name } -> + { Ast_404.Outcometree.oattr_name = oattr_name } and copy_out_variant : - From.Outcometree.out_variant -> To.Outcometree.out_variant = + Ast_403.Outcometree.out_variant -> Ast_404.Outcometree.out_variant = function - | From.Outcometree.Ovar_fields x0 -> - To.Outcometree.Ovar_fields + | Ast_403.Outcometree.Ovar_fields x0 -> + Ast_404.Outcometree.Ovar_fields (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), - (List.map copy_out_type x2))) x0) - | From.Outcometree.Ovar_name (x0,x1) -> - To.Outcometree.Ovar_name - ((copy_out_ident x0), - (List.map copy_out_type x1)) - + (fun x -> + let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2))) + x0) + | Ast_403.Outcometree.Ovar_name (x0, x1) -> + Ast_404.Outcometree.Ovar_name + ((copy_out_ident x0), (List.map copy_out_type x1)) and copy_out_value : - From.Outcometree.out_value -> To.Outcometree.out_value = - function - | From.Outcometree.Oval_array x0 -> - To.Outcometree.Oval_array - (List.map copy_out_value x0) - | From.Outcometree.Oval_char x0 -> To.Outcometree.Oval_char x0 - | From.Outcometree.Oval_constr (x0,x1) -> - To.Outcometree.Oval_constr - ((copy_out_ident x0), - (List.map copy_out_value x1)) - | From.Outcometree.Oval_ellipsis -> To.Outcometree.Oval_ellipsis - | From.Outcometree.Oval_float x0 -> - To.Outcometree.Oval_float (copy_float x0) - | From.Outcometree.Oval_int x0 -> To.Outcometree.Oval_int x0 - | From.Outcometree.Oval_int32 x0 -> To.Outcometree.Oval_int32 x0 - | From.Outcometree.Oval_int64 x0 -> To.Outcometree.Oval_int64 x0 - | From.Outcometree.Oval_nativeint x0 -> - To.Outcometree.Oval_nativeint x0 - | From.Outcometree.Oval_list x0 -> - To.Outcometree.Oval_list - (List.map copy_out_value x0) - | From.Outcometree.Oval_printer x0 -> - To.Outcometree.Oval_printer x0 - | From.Outcometree.Oval_record x0 -> - To.Outcometree.Oval_record + Ast_403.Outcometree.out_value -> Ast_404.Outcometree.out_value = + function + | Ast_403.Outcometree.Oval_array x0 -> + Ast_404.Outcometree.Oval_array (List.map copy_out_value x0) + | Ast_403.Outcometree.Oval_char x0 -> Ast_404.Outcometree.Oval_char x0 + | Ast_403.Outcometree.Oval_constr (x0, x1) -> + Ast_404.Outcometree.Oval_constr + ((copy_out_ident x0), (List.map copy_out_value x1)) + | Ast_403.Outcometree.Oval_ellipsis -> Ast_404.Outcometree.Oval_ellipsis + | Ast_403.Outcometree.Oval_float x0 -> Ast_404.Outcometree.Oval_float x0 + | Ast_403.Outcometree.Oval_int x0 -> Ast_404.Outcometree.Oval_int x0 + | Ast_403.Outcometree.Oval_int32 x0 -> Ast_404.Outcometree.Oval_int32 x0 + | Ast_403.Outcometree.Oval_int64 x0 -> Ast_404.Outcometree.Oval_int64 x0 + | Ast_403.Outcometree.Oval_nativeint x0 -> + Ast_404.Outcometree.Oval_nativeint x0 + | Ast_403.Outcometree.Oval_list x0 -> + Ast_404.Outcometree.Oval_list (List.map copy_out_value x0) + | Ast_403.Outcometree.Oval_printer x0 -> + Ast_404.Outcometree.Oval_printer x0 + | Ast_403.Outcometree.Oval_record x0 -> + Ast_404.Outcometree.Oval_record (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_ident x0), - (copy_out_value x1))) x0) - | From.Outcometree.Oval_string x0 -> To.Outcometree.Oval_string x0 - | From.Outcometree.Oval_stuff x0 -> To.Outcometree.Oval_stuff x0 - | From.Outcometree.Oval_tuple x0 -> - To.Outcometree.Oval_tuple - (List.map copy_out_value x0) - | From.Outcometree.Oval_variant (x0,x1) -> - To.Outcometree.Oval_variant - (x0, (copy_option copy_out_value x1)) - -and copy_float : float -> float = fun x -> x - + (fun x -> + let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1))) + x0) + | Ast_403.Outcometree.Oval_string x0 -> Ast_404.Outcometree.Oval_string x0 + | Ast_403.Outcometree.Oval_stuff x0 -> Ast_404.Outcometree.Oval_stuff x0 + | Ast_403.Outcometree.Oval_tuple x0 -> + Ast_404.Outcometree.Oval_tuple (List.map copy_out_value x0) + | Ast_403.Outcometree.Oval_variant (x0, x1) -> + Ast_404.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1)) and copy_out_ident : - From.Outcometree.out_ident -> To.Outcometree.out_ident = - function - | From.Outcometree.Oide_apply (x0,x1) -> - To.Outcometree.Oide_apply ((copy_out_ident x0), (copy_out_ident x1)) - | From.Outcometree.Oide_dot (x0,x1) -> - To.Outcometree.Oide_dot ((copy_out_ident x0), x1) - | From.Outcometree.Oide_ident x0 -> To.Outcometree.Oide_ident x0 - -let rec copy_toplevel_phrase : - From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = - function - | From.Parsetree.Ptop_def x0 -> - To.Parsetree.Ptop_def (copy_structure x0) - | From.Parsetree.Ptop_dir (x0,x1) -> - To.Parsetree.Ptop_dir (x0, copy_directive_argument x1) - -and copy_directive_argument : - From.Parsetree.directive_argument -> To.Parsetree.directive_argument = - function - | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none - | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 - | From.Parsetree.Pdir_int (x0,x1) -> - To.Parsetree.Pdir_int (x0, copy_option (fun x -> x) x1) - | From.Parsetree.Pdir_ident x0 -> - To.Parsetree.Pdir_ident (copy_longident x0) - | From.Parsetree.Pdir_bool x0 -> - To.Parsetree.Pdir_bool (copy_bool x0) - -let copy_out_type_extension : - From.Outcometree.out_type_extension -> To.Outcometree.out_type_extension = - fun - { From.Outcometree.otyext_name = otyext_name; - From.Outcometree.otyext_params = otyext_params; - From.Outcometree.otyext_constructors = otyext_constructors; - From.Outcometree.otyext_private = otyext_private } - -> - { - To.Outcometree.otyext_name = otyext_name; - To.Outcometree.otyext_params = - (List.map (fun x -> x) otyext_params); - To.Outcometree.otyext_constructors = - (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) - otyext_constructors); - To.Outcometree.otyext_private = - (copy_private_flag otyext_private) - } - -let copy_cases x = List.map copy_case x -let copy_pat = copy_pattern -let copy_expr = copy_expression -let copy_typ = copy_core_type + Ast_403.Outcometree.out_ident -> Ast_404.Outcometree.out_ident = + function + | Ast_403.Outcometree.Oide_apply (x0, x1) -> + Ast_404.Outcometree.Oide_apply + ((copy_out_ident x0), (copy_out_ident x1)) + | Ast_403.Outcometree.Oide_dot (x0, x1) -> + Ast_404.Outcometree.Oide_dot ((copy_out_ident x0), x1) + | Ast_403.Outcometree.Oide_ident x0 -> Ast_404.Outcometree.Oide_ident x0 diff --git a/src/vendored-omp/src/migrate_parsetree_404_403.ml b/src/vendored-omp/src/migrate_parsetree_404_403.ml index 4dc190899..e989d67a8 100644 --- a/src/vendored-omp/src/migrate_parsetree_404_403.ml +++ b/src/vendored-omp/src/migrate_parsetree_404_403.ml @@ -15,116 +15,3 @@ include Migrate_parsetree_404_403_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - (*$*) - } as mapper) -> - let module R = Migrate_parsetree_403_404_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_404_403_migrate.ml b/src/vendored-omp/src/migrate_parsetree_404_403_migrate.ml index 2f69e3fd4..0ffe324a8 100644 --- a/src/vendored-omp/src/migrate_parsetree_404_403_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_404_403_migrate.ml @@ -1,1605 +1,95 @@ -(**************************************************************************) -(* *) -(* OCaml Migrate Parsetree *) -(* *) -(* Frédéric Bour *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2017 Institut National de Recherche en Informatique et *) -(* en Automatique (INRIA). *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -module Def = Migrate_parsetree_def +open Stdlib0 module From = Ast_404 module To = Ast_403 - -let from_loc {From.Location. txt = _; loc} = loc - -let migration_error location feature = - raise (Def.Migration_error (feature, location)) - -let rec copy_expression : - From.Parsetree.expression -> - To.Parsetree.expression - = - fun - { From.Parsetree.pexp_desc = pexp_desc; - From.Parsetree.pexp_loc = pexp_loc; - From.Parsetree.pexp_attributes = pexp_attributes } - -> - { - To.Parsetree.pexp_desc = - (copy_expression_desc pexp_loc pexp_desc); - To.Parsetree.pexp_loc = - (copy_location pexp_loc); - To.Parsetree.pexp_attributes = - (copy_attributes pexp_attributes) - } - -and copy_expression_desc loc : - From.Parsetree.expression_desc -> - To.Parsetree.expression_desc - = - function - | From.Parsetree.Pexp_ident x0 -> - To.Parsetree.Pexp_ident - (copy_loc copy_longident - x0) - | From.Parsetree.Pexp_constant x0 -> - To.Parsetree.Pexp_constant - (copy_constant x0) - | From.Parsetree.Pexp_let (x0,x1,x2) -> - To.Parsetree.Pexp_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_expression x2)) - | From.Parsetree.Pexp_function x0 -> - To.Parsetree.Pexp_function - (List.map copy_case x0) - | From.Parsetree.Pexp_fun (x0,x1,x2,x3) -> - To.Parsetree.Pexp_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_expression x3)) - | From.Parsetree.Pexp_apply (x0,x1) -> - To.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pexp_match (x0,x1) -> - To.Parsetree.Pexp_match - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_try (x0,x1) -> - To.Parsetree.Pexp_try - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_tuple x0 -> - To.Parsetree.Pexp_tuple - (List.map copy_expression x0) - | From.Parsetree.Pexp_construct (x0,x1) -> - To.Parsetree.Pexp_construct - ((copy_loc - copy_longident x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_variant (x0,x1) -> - To.Parsetree.Pexp_variant - ((copy_label x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_record (x0,x1) -> - To.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc - copy_longident x0), - (copy_expression x1))) x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_field (x0,x1) -> - To.Parsetree.Pexp_field - ((copy_expression x0), - (copy_loc - copy_longident x1)) - | From.Parsetree.Pexp_setfield (x0,x1,x2) -> - To.Parsetree.Pexp_setfield - ((copy_expression x0), - (copy_loc - copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_array x0 -> - To.Parsetree.Pexp_array - (List.map copy_expression x0) - | From.Parsetree.Pexp_ifthenelse (x0,x1,x2) -> - To.Parsetree.Pexp_ifthenelse - ((copy_expression x0), - (copy_expression x1), - (copy_option copy_expression x2)) - | From.Parsetree.Pexp_sequence (x0,x1) -> - To.Parsetree.Pexp_sequence - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_while (x0,x1) -> - To.Parsetree.Pexp_while - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_for (x0,x1,x2,x3,x4) -> - To.Parsetree.Pexp_for - ((copy_pattern x0), - (copy_expression x1), - (copy_expression x2), - (copy_direction_flag x3), - (copy_expression x4)) - | From.Parsetree.Pexp_constraint (x0,x1) -> - To.Parsetree.Pexp_constraint - ((copy_expression x0), - (copy_core_type x1)) - | From.Parsetree.Pexp_coerce (x0,x1,x2) -> - To.Parsetree.Pexp_coerce - ((copy_expression x0), - (copy_option copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Pexp_send (x0,x1) -> - To.Parsetree.Pexp_send - ((copy_expression x0), x1) - | From.Parsetree.Pexp_new x0 -> - To.Parsetree.Pexp_new - (copy_loc copy_longident - x0) - | From.Parsetree.Pexp_setinstvar (x0,x1) -> - To.Parsetree.Pexp_setinstvar - ((copy_loc (fun x -> x) x0), - (copy_expression x1)) - | From.Parsetree.Pexp_override x0 -> - To.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_expression x1))) x0) - | From.Parsetree.Pexp_letmodule (x0,x1,x2) -> - To.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> x) x0), - (copy_module_expr x1), - (copy_expression x2)) - | From.Parsetree.Pexp_letexception _ -> - migration_error loc Def.Pexp_letexception - | From.Parsetree.Pexp_assert x0 -> - To.Parsetree.Pexp_assert - (copy_expression x0) - | From.Parsetree.Pexp_lazy x0 -> - To.Parsetree.Pexp_lazy - (copy_expression x0) - | From.Parsetree.Pexp_poly (x0,x1) -> - To.Parsetree.Pexp_poly - ((copy_expression x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pexp_object x0 -> - To.Parsetree.Pexp_object - (copy_class_structure x0) - | From.Parsetree.Pexp_newtype (x0,x1) -> - To.Parsetree.Pexp_newtype - (x0, (copy_expression x1)) - | From.Parsetree.Pexp_pack x0 -> - To.Parsetree.Pexp_pack - (copy_module_expr x0) - | From.Parsetree.Pexp_open (x0,x1,x2) -> - To.Parsetree.Pexp_open - ((copy_override_flag x0), - (copy_loc - copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_extension x0 -> - To.Parsetree.Pexp_extension - (copy_extension x0) - | From.Parsetree.Pexp_unreachable -> - To.Parsetree.Pexp_unreachable - -and copy_direction_flag : - From.Asttypes.direction_flag -> - To.Asttypes.direction_flag - = - function - | From.Asttypes.Upto -> To.Asttypes.Upto - | From.Asttypes.Downto -> To.Asttypes.Downto - -and copy_case : - From.Parsetree.case -> To.Parsetree.case = - fun - { From.Parsetree.pc_lhs = pc_lhs; - From.Parsetree.pc_guard = pc_guard; - From.Parsetree.pc_rhs = pc_rhs } - -> - { - To.Parsetree.pc_lhs = - (copy_pattern pc_lhs); - To.Parsetree.pc_guard = - (copy_option copy_expression pc_guard); - To.Parsetree.pc_rhs = - (copy_expression pc_rhs) - } - -and copy_value_binding : - From.Parsetree.value_binding -> - To.Parsetree.value_binding - = - fun - { From.Parsetree.pvb_pat = pvb_pat; - From.Parsetree.pvb_expr = pvb_expr; - From.Parsetree.pvb_attributes = pvb_attributes; - From.Parsetree.pvb_loc = pvb_loc } - -> - { - To.Parsetree.pvb_pat = - (copy_pattern pvb_pat); - To.Parsetree.pvb_expr = - (copy_expression pvb_expr); - To.Parsetree.pvb_attributes = - (copy_attributes pvb_attributes); - To.Parsetree.pvb_loc = - (copy_location pvb_loc) - } - -and copy_pattern : - From.Parsetree.pattern -> To.Parsetree.pattern = - fun - { From.Parsetree.ppat_desc = ppat_desc; - From.Parsetree.ppat_loc = ppat_loc; - From.Parsetree.ppat_attributes = ppat_attributes } - -> - { - To.Parsetree.ppat_desc = - (copy_pattern_desc ppat_loc ppat_desc); - To.Parsetree.ppat_loc = - (copy_location ppat_loc); - To.Parsetree.ppat_attributes = - (copy_attributes ppat_attributes) - } - -and copy_pattern_desc loc : - From.Parsetree.pattern_desc -> - To.Parsetree.pattern_desc - = - function - | From.Parsetree.Ppat_any -> - To.Parsetree.Ppat_any - | From.Parsetree.Ppat_var x0 -> - To.Parsetree.Ppat_var - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_alias (x0,x1) -> - To.Parsetree.Ppat_alias - ((copy_pattern x0), - (copy_loc (fun x -> x) x1)) - | From.Parsetree.Ppat_constant x0 -> - To.Parsetree.Ppat_constant - (copy_constant x0) - | From.Parsetree.Ppat_interval (x0,x1) -> - To.Parsetree.Ppat_interval - ((copy_constant x0), - (copy_constant x1)) - | From.Parsetree.Ppat_tuple x0 -> - To.Parsetree.Ppat_tuple - (List.map copy_pattern x0) - | From.Parsetree.Ppat_construct (x0,x1) -> - To.Parsetree.Ppat_construct - ((copy_loc - copy_longident x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_variant (x0,x1) -> - To.Parsetree.Ppat_variant - ((copy_label x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_record (x0,x1) -> - To.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc - copy_longident x0), - (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ppat_array x0 -> - To.Parsetree.Ppat_array - (List.map copy_pattern x0) - | From.Parsetree.Ppat_or (x0,x1) -> - To.Parsetree.Ppat_or - ((copy_pattern x0), - (copy_pattern x1)) - | From.Parsetree.Ppat_constraint (x0,x1) -> - To.Parsetree.Ppat_constraint - ((copy_pattern x0), - (copy_core_type x1)) - | From.Parsetree.Ppat_type x0 -> - To.Parsetree.Ppat_type - (copy_loc copy_longident - x0) - | From.Parsetree.Ppat_lazy x0 -> - To.Parsetree.Ppat_lazy - (copy_pattern x0) - | From.Parsetree.Ppat_unpack x0 -> - To.Parsetree.Ppat_unpack - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_exception x0 -> - To.Parsetree.Ppat_exception - (copy_pattern x0) - | From.Parsetree.Ppat_extension x0 -> - To.Parsetree.Ppat_extension - (copy_extension x0) - | From.Parsetree.Ppat_open _ -> - migration_error loc Def.Ppat_open -and copy_core_type : - From.Parsetree.core_type -> - To.Parsetree.core_type - = - fun - { From.Parsetree.ptyp_desc = ptyp_desc; - From.Parsetree.ptyp_loc = ptyp_loc; - From.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - To.Parsetree.ptyp_desc = - (copy_core_type_desc ptyp_desc); - To.Parsetree.ptyp_loc = - (copy_location ptyp_loc); - To.Parsetree.ptyp_attributes = - (copy_attributes ptyp_attributes) - } - -and copy_core_type_desc : - From.Parsetree.core_type_desc -> - To.Parsetree.core_type_desc - = - function - | From.Parsetree.Ptyp_any -> - To.Parsetree.Ptyp_any - | From.Parsetree.Ptyp_var x0 -> - To.Parsetree.Ptyp_var x0 - | From.Parsetree.Ptyp_arrow (x0,x1,x2) -> - To.Parsetree.Ptyp_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Ptyp_tuple x0 -> - To.Parsetree.Ptyp_tuple - (List.map copy_core_type x0) - | From.Parsetree.Ptyp_constr (x0,x1) -> - To.Parsetree.Ptyp_constr - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_object (x0,x1) -> - To.Parsetree.Ptyp_object - ((List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_attributes x1), - (copy_core_type x2))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ptyp_class (x0,x1) -> - To.Parsetree.Ptyp_class - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_alias (x0,x1) -> - To.Parsetree.Ptyp_alias - ((copy_core_type x0), x1) - | From.Parsetree.Ptyp_variant (x0,x1,x2) -> - To.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), - (copy_closed_flag x1), - (copy_option - (fun x -> List.map copy_label x) x2)) - | From.Parsetree.Ptyp_poly (x0,x1) -> - To.Parsetree.Ptyp_poly - ((List.map (fun x -> x) x0), - (copy_core_type x1)) - | From.Parsetree.Ptyp_package x0 -> - To.Parsetree.Ptyp_package - (copy_package_type x0) - | From.Parsetree.Ptyp_extension x0 -> - To.Parsetree.Ptyp_extension - (copy_extension x0) - -and copy_package_type : - From.Parsetree.package_type -> - To.Parsetree.package_type - = - fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc - copy_longident x0), - (copy_core_type x1))) x1)) - -and copy_row_field : - From.Parsetree.row_field -> - To.Parsetree.row_field - = - function - | From.Parsetree.Rtag (x0,x1,x2,x3) -> - To.Parsetree.Rtag - ((copy_label x0), - (copy_attributes x1), (copy_bool x2), - (List.map copy_core_type x3)) - | From.Parsetree.Rinherit x0 -> - To.Parsetree.Rinherit - (copy_core_type x0) - -and copy_attributes : - From.Parsetree.attributes -> - To.Parsetree.attributes - = fun x -> List.map copy_attribute x - -and copy_attribute : - From.Parsetree.attribute -> - To.Parsetree.attribute - = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_payload : - From.Parsetree.payload -> To.Parsetree.payload = - function - | From.Parsetree.PStr x0 -> - To.Parsetree.PStr - (copy_structure x0) - | From.Parsetree.PSig x0 -> - To.Parsetree.PSig - (copy_signature x0) - | From.Parsetree.PTyp x0 -> - To.Parsetree.PTyp - (copy_core_type x0) - | From.Parsetree.PPat (x0,x1) -> - To.Parsetree.PPat - ((copy_pattern x0), - (copy_option copy_expression x1)) - -and copy_structure : - From.Parsetree.structure -> - To.Parsetree.structure - = fun x -> List.map copy_structure_item x - -and copy_structure_item : - From.Parsetree.structure_item -> - To.Parsetree.structure_item - = - fun - { From.Parsetree.pstr_desc = pstr_desc; - From.Parsetree.pstr_loc = pstr_loc } - -> - { - To.Parsetree.pstr_desc = - (copy_structure_item_desc pstr_desc); - To.Parsetree.pstr_loc = - (copy_location pstr_loc) - } - -and copy_structure_item_desc : - From.Parsetree.structure_item_desc -> - To.Parsetree.structure_item_desc - = - function - | From.Parsetree.Pstr_eval (x0,x1) -> - To.Parsetree.Pstr_eval - ((copy_expression x0), - (copy_attributes x1)) - | From.Parsetree.Pstr_value (x0,x1) -> - To.Parsetree.Pstr_value - ((copy_rec_flag x0), - (List.map copy_value_binding x1)) - | From.Parsetree.Pstr_primitive x0 -> - To.Parsetree.Pstr_primitive - (copy_value_description x0) - | From.Parsetree.Pstr_type (x0,x1) -> - To.Parsetree.Pstr_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Pstr_typext x0 -> - To.Parsetree.Pstr_typext - (copy_type_extension x0) - | From.Parsetree.Pstr_exception x0 -> - To.Parsetree.Pstr_exception - (copy_extension_constructor x0) - | From.Parsetree.Pstr_module x0 -> - To.Parsetree.Pstr_module - (copy_module_binding x0) - | From.Parsetree.Pstr_recmodule x0 -> - To.Parsetree.Pstr_recmodule - (List.map copy_module_binding x0) - | From.Parsetree.Pstr_modtype x0 -> - To.Parsetree.Pstr_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Pstr_open x0 -> - To.Parsetree.Pstr_open - (copy_open_description x0) - | From.Parsetree.Pstr_class x0 -> - To.Parsetree.Pstr_class - (List.map copy_class_declaration x0) - | From.Parsetree.Pstr_class_type x0 -> - To.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Pstr_include x0 -> - To.Parsetree.Pstr_include - (copy_include_declaration x0) - | From.Parsetree.Pstr_attribute x0 -> - To.Parsetree.Pstr_attribute - (copy_attribute x0) - | From.Parsetree.Pstr_extension (x0,x1) -> - To.Parsetree.Pstr_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_include_declaration : - From.Parsetree.include_declaration -> - To.Parsetree.include_declaration - = - fun x -> - copy_include_infos - copy_module_expr x - -and copy_class_declaration : - From.Parsetree.class_declaration -> - To.Parsetree.class_declaration - = - fun x -> - copy_class_infos - copy_class_expr x - -and copy_class_expr : - From.Parsetree.class_expr -> - To.Parsetree.class_expr - = - fun - { From.Parsetree.pcl_desc = pcl_desc; - From.Parsetree.pcl_loc = pcl_loc; - From.Parsetree.pcl_attributes = pcl_attributes } - -> - { - To.Parsetree.pcl_desc = - (copy_class_expr_desc pcl_desc); - To.Parsetree.pcl_loc = - (copy_location pcl_loc); - To.Parsetree.pcl_attributes = - (copy_attributes pcl_attributes) - } - -and copy_class_expr_desc : - From.Parsetree.class_expr_desc -> - To.Parsetree.class_expr_desc - = - function - | From.Parsetree.Pcl_constr (x0,x1) -> - To.Parsetree.Pcl_constr - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcl_structure x0 -> - To.Parsetree.Pcl_structure - (copy_class_structure x0) - | From.Parsetree.Pcl_fun (x0,x1,x2,x3) -> - To.Parsetree.Pcl_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_class_expr x3)) - | From.Parsetree.Pcl_apply (x0,x1) -> - To.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pcl_let (x0,x1,x2) -> - To.Parsetree.Pcl_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_class_expr x2)) - | From.Parsetree.Pcl_constraint (x0,x1) -> - To.Parsetree.Pcl_constraint - ((copy_class_expr x0), - (copy_class_type x1)) - | From.Parsetree.Pcl_extension x0 -> - To.Parsetree.Pcl_extension - (copy_extension x0) - -and copy_class_structure : - From.Parsetree.class_structure -> - To.Parsetree.class_structure - = - fun - { From.Parsetree.pcstr_self = pcstr_self; - From.Parsetree.pcstr_fields = pcstr_fields } - -> - { - To.Parsetree.pcstr_self = - (copy_pattern pcstr_self); - To.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } - -and copy_class_field : - From.Parsetree.class_field -> - To.Parsetree.class_field - = - fun - { From.Parsetree.pcf_desc = pcf_desc; - From.Parsetree.pcf_loc = pcf_loc; - From.Parsetree.pcf_attributes = pcf_attributes } - -> - { - To.Parsetree.pcf_desc = - (copy_class_field_desc pcf_desc); - To.Parsetree.pcf_loc = - (copy_location pcf_loc); - To.Parsetree.pcf_attributes = - (copy_attributes pcf_attributes) - } - -and copy_class_field_desc : - From.Parsetree.class_field_desc -> - To.Parsetree.class_field_desc - = - function - | From.Parsetree.Pcf_inherit (x0,x1,x2) -> - To.Parsetree.Pcf_inherit - ((copy_override_flag x0), - (copy_class_expr x1), - (copy_option (fun x -> x) x2)) - | From.Parsetree.Pcf_val x0 -> - To.Parsetree.Pcf_val - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_method x0 -> - To.Parsetree.Pcf_method - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_private_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_constraint x0 -> - To.Parsetree.Pcf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pcf_initializer x0 -> - To.Parsetree.Pcf_initializer - (copy_expression x0) - | From.Parsetree.Pcf_attribute x0 -> - To.Parsetree.Pcf_attribute - (copy_attribute x0) - | From.Parsetree.Pcf_extension x0 -> - To.Parsetree.Pcf_extension - (copy_extension x0) - -and copy_class_field_kind : - From.Parsetree.class_field_kind -> - To.Parsetree.class_field_kind - = - function - | From.Parsetree.Cfk_virtual x0 -> - To.Parsetree.Cfk_virtual - (copy_core_type x0) - | From.Parsetree.Cfk_concrete (x0,x1) -> - To.Parsetree.Cfk_concrete - ((copy_override_flag x0), - (copy_expression x1)) - -and copy_module_binding : - From.Parsetree.module_binding -> - To.Parsetree.module_binding - = - fun - { From.Parsetree.pmb_name = pmb_name; - From.Parsetree.pmb_expr = pmb_expr; - From.Parsetree.pmb_attributes = pmb_attributes; - From.Parsetree.pmb_loc = pmb_loc } - -> - { - To.Parsetree.pmb_name = - (copy_loc (fun x -> x) pmb_name); - To.Parsetree.pmb_expr = - (copy_module_expr pmb_expr); - To.Parsetree.pmb_attributes = - (copy_attributes pmb_attributes); - To.Parsetree.pmb_loc = - (copy_location pmb_loc) - } - -and copy_module_expr : - From.Parsetree.module_expr -> - To.Parsetree.module_expr - = - fun - { From.Parsetree.pmod_desc = pmod_desc; - From.Parsetree.pmod_loc = pmod_loc; - From.Parsetree.pmod_attributes = pmod_attributes } - -> - { - To.Parsetree.pmod_desc = - (copy_module_expr_desc pmod_desc); - To.Parsetree.pmod_loc = - (copy_location pmod_loc); - To.Parsetree.pmod_attributes = - (copy_attributes pmod_attributes) - } - -and copy_module_expr_desc : - From.Parsetree.module_expr_desc -> - To.Parsetree.module_expr_desc - = - function - | From.Parsetree.Pmod_ident x0 -> - To.Parsetree.Pmod_ident - (copy_loc copy_longident - x0) - | From.Parsetree.Pmod_structure x0 -> - To.Parsetree.Pmod_structure - (copy_structure x0) - | From.Parsetree.Pmod_functor (x0,x1,x2) -> - To.Parsetree.Pmod_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_expr x2)) - | From.Parsetree.Pmod_apply (x0,x1) -> - To.Parsetree.Pmod_apply - ((copy_module_expr x0), - (copy_module_expr x1)) - | From.Parsetree.Pmod_constraint (x0,x1) -> - To.Parsetree.Pmod_constraint - ((copy_module_expr x0), - (copy_module_type x1)) - | From.Parsetree.Pmod_unpack x0 -> - To.Parsetree.Pmod_unpack - (copy_expression x0) - | From.Parsetree.Pmod_extension x0 -> - To.Parsetree.Pmod_extension - (copy_extension x0) - -and copy_module_type : - From.Parsetree.module_type -> - To.Parsetree.module_type - = - fun - { From.Parsetree.pmty_desc = pmty_desc; - From.Parsetree.pmty_loc = pmty_loc; - From.Parsetree.pmty_attributes = pmty_attributes } - -> - { - To.Parsetree.pmty_desc = - (copy_module_type_desc pmty_desc); - To.Parsetree.pmty_loc = - (copy_location pmty_loc); - To.Parsetree.pmty_attributes = - (copy_attributes pmty_attributes) - } - -and copy_module_type_desc : - From.Parsetree.module_type_desc -> - To.Parsetree.module_type_desc - = - function - | From.Parsetree.Pmty_ident x0 -> - To.Parsetree.Pmty_ident - (copy_loc copy_longident - x0) - | From.Parsetree.Pmty_signature x0 -> - To.Parsetree.Pmty_signature - (copy_signature x0) - | From.Parsetree.Pmty_functor (x0,x1,x2) -> - To.Parsetree.Pmty_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_type x2)) - | From.Parsetree.Pmty_with (x0,x1) -> - To.Parsetree.Pmty_with - ((copy_module_type x0), - (List.map copy_with_constraint x1)) - | From.Parsetree.Pmty_typeof x0 -> - To.Parsetree.Pmty_typeof - (copy_module_expr x0) - | From.Parsetree.Pmty_extension x0 -> - To.Parsetree.Pmty_extension - (copy_extension x0) - | From.Parsetree.Pmty_alias x0 -> - To.Parsetree.Pmty_alias - (copy_loc copy_longident - x0) - -and copy_with_constraint : - From.Parsetree.with_constraint -> - To.Parsetree.with_constraint - = - function - | From.Parsetree.Pwith_type (x0,x1) -> - To.Parsetree.Pwith_type - ((copy_loc - copy_longident x0), - (copy_type_declaration x1)) - | From.Parsetree.Pwith_module (x0,x1) -> - To.Parsetree.Pwith_module - ((copy_loc - copy_longident x0), - (copy_loc - copy_longident x1)) - | From.Parsetree.Pwith_typesubst x0 -> - To.Parsetree.Pwith_typesubst - (copy_type_declaration x0) - | From.Parsetree.Pwith_modsubst (x0,x1) -> - To.Parsetree.Pwith_modsubst - ((copy_loc (fun x -> x) x0), - (copy_loc - copy_longident x1)) - -and copy_signature : - From.Parsetree.signature -> - To.Parsetree.signature - = fun x -> List.map copy_signature_item x - -and copy_signature_item : - From.Parsetree.signature_item -> - To.Parsetree.signature_item - = - fun - { From.Parsetree.psig_desc = psig_desc; - From.Parsetree.psig_loc = psig_loc } - -> - { - To.Parsetree.psig_desc = - (copy_signature_item_desc psig_desc); - To.Parsetree.psig_loc = - (copy_location psig_loc) - } - -and copy_signature_item_desc : - From.Parsetree.signature_item_desc -> - To.Parsetree.signature_item_desc - = - function - | From.Parsetree.Psig_value x0 -> - To.Parsetree.Psig_value - (copy_value_description x0) - | From.Parsetree.Psig_type (x0,x1) -> - To.Parsetree.Psig_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Psig_typext x0 -> - To.Parsetree.Psig_typext - (copy_type_extension x0) - | From.Parsetree.Psig_exception x0 -> - To.Parsetree.Psig_exception - (copy_extension_constructor x0) - | From.Parsetree.Psig_module x0 -> - To.Parsetree.Psig_module - (copy_module_declaration x0) - | From.Parsetree.Psig_recmodule x0 -> - To.Parsetree.Psig_recmodule - (List.map copy_module_declaration x0) - | From.Parsetree.Psig_modtype x0 -> - To.Parsetree.Psig_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Psig_open x0 -> - To.Parsetree.Psig_open - (copy_open_description x0) - | From.Parsetree.Psig_include x0 -> - To.Parsetree.Psig_include - (copy_include_description x0) - | From.Parsetree.Psig_class x0 -> - To.Parsetree.Psig_class - (List.map copy_class_description x0) - | From.Parsetree.Psig_class_type x0 -> - To.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Psig_attribute x0 -> - To.Parsetree.Psig_attribute - (copy_attribute x0) - | From.Parsetree.Psig_extension (x0,x1) -> - To.Parsetree.Psig_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_class_type_declaration : - From.Parsetree.class_type_declaration -> - To.Parsetree.class_type_declaration - = - fun x -> - copy_class_infos - copy_class_type x - -and copy_class_description : - From.Parsetree.class_description -> - To.Parsetree.class_description - = - fun x -> - copy_class_infos - copy_class_type x - -and copy_class_type : - From.Parsetree.class_type -> - To.Parsetree.class_type - = - fun - { From.Parsetree.pcty_desc = pcty_desc; - From.Parsetree.pcty_loc = pcty_loc; - From.Parsetree.pcty_attributes = pcty_attributes } - -> - { - To.Parsetree.pcty_desc = - (copy_class_type_desc pcty_desc); - To.Parsetree.pcty_loc = - (copy_location pcty_loc); - To.Parsetree.pcty_attributes = - (copy_attributes pcty_attributes) - } - -and copy_class_type_desc : - From.Parsetree.class_type_desc -> - To.Parsetree.class_type_desc - = - function - | From.Parsetree.Pcty_constr (x0,x1) -> - To.Parsetree.Pcty_constr - ((copy_loc - copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcty_signature x0 -> - To.Parsetree.Pcty_signature - (copy_class_signature x0) - | From.Parsetree.Pcty_arrow (x0,x1,x2) -> - To.Parsetree.Pcty_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_class_type x2)) - | From.Parsetree.Pcty_extension x0 -> - To.Parsetree.Pcty_extension - (copy_extension x0) - -and copy_class_signature : - From.Parsetree.class_signature -> - To.Parsetree.class_signature - = - fun - { From.Parsetree.pcsig_self = pcsig_self; - From.Parsetree.pcsig_fields = pcsig_fields } - -> - { - To.Parsetree.pcsig_self = - (copy_core_type pcsig_self); - To.Parsetree.pcsig_fields = - (List.map copy_class_type_field - pcsig_fields) - } - -and copy_class_type_field : - From.Parsetree.class_type_field -> - To.Parsetree.class_type_field - = - fun - { From.Parsetree.pctf_desc = pctf_desc; - From.Parsetree.pctf_loc = pctf_loc; - From.Parsetree.pctf_attributes = pctf_attributes } - -> - { - To.Parsetree.pctf_desc = - (copy_class_type_field_desc pctf_desc); - To.Parsetree.pctf_loc = - (copy_location pctf_loc); - To.Parsetree.pctf_attributes = - (copy_attributes pctf_attributes) - } - -and copy_class_type_field_desc : - From.Parsetree.class_type_field_desc -> - To.Parsetree.class_type_field_desc - = - function - | From.Parsetree.Pctf_inherit x0 -> - To.Parsetree.Pctf_inherit - (copy_class_type x0) - | From.Parsetree.Pctf_val x0 -> - To.Parsetree.Pctf_val - (let (x0,x1,x2,x3) = x0 in - (x0, (copy_mutable_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_method x0 -> - To.Parsetree.Pctf_method - (let (x0,x1,x2,x3) = x0 in - (x0, (copy_private_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_constraint x0 -> - To.Parsetree.Pctf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pctf_attribute x0 -> - To.Parsetree.Pctf_attribute - (copy_attribute x0) - | From.Parsetree.Pctf_extension x0 -> - To.Parsetree.Pctf_extension - (copy_extension x0) - -and copy_extension : - From.Parsetree.extension -> - To.Parsetree.extension - = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.class_infos -> - 'g0 To.Parsetree.class_infos - = - fun f0 -> - fun - { From.Parsetree.pci_virt = pci_virt; - From.Parsetree.pci_params = pci_params; - From.Parsetree.pci_name = pci_name; - From.Parsetree.pci_expr = pci_expr; - From.Parsetree.pci_loc = pci_loc; - From.Parsetree.pci_attributes = pci_attributes } - -> - { - To.Parsetree.pci_virt = - (copy_virtual_flag pci_virt); - To.Parsetree.pci_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) pci_params); - To.Parsetree.pci_name = - (copy_loc (fun x -> x) pci_name); - To.Parsetree.pci_expr = (f0 pci_expr); - To.Parsetree.pci_loc = - (copy_location pci_loc); - To.Parsetree.pci_attributes = - (copy_attributes pci_attributes) - } - -and copy_virtual_flag : - From.Asttypes.virtual_flag -> - To.Asttypes.virtual_flag - = - function - | From.Asttypes.Virtual -> To.Asttypes.Virtual - | From.Asttypes.Concrete -> To.Asttypes.Concrete - -and copy_include_description : - From.Parsetree.include_description -> - To.Parsetree.include_description - = - fun x -> - copy_include_infos - copy_module_type x - -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.include_infos -> - 'g0 To.Parsetree.include_infos - = - fun f0 -> - fun - { From.Parsetree.pincl_mod = pincl_mod; - From.Parsetree.pincl_loc = pincl_loc; - From.Parsetree.pincl_attributes = pincl_attributes } - -> - { - To.Parsetree.pincl_mod = (f0 pincl_mod); - To.Parsetree.pincl_loc = - (copy_location pincl_loc); - To.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } - -and copy_open_description : - From.Parsetree.open_description -> - To.Parsetree.open_description - = - fun - { From.Parsetree.popen_lid = popen_lid; - From.Parsetree.popen_override = popen_override; - From.Parsetree.popen_loc = popen_loc; - From.Parsetree.popen_attributes = popen_attributes } - -> - { - To.Parsetree.popen_lid = - (copy_loc copy_longident - popen_lid); - To.Parsetree.popen_override = - (copy_override_flag popen_override); - To.Parsetree.popen_loc = - (copy_location popen_loc); - To.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } - -and copy_override_flag : - From.Asttypes.override_flag -> - To.Asttypes.override_flag - = - function - | From.Asttypes.Override -> To.Asttypes.Override - | From.Asttypes.Fresh -> To.Asttypes.Fresh - -and copy_module_type_declaration : - From.Parsetree.module_type_declaration -> - To.Parsetree.module_type_declaration - = - fun - { From.Parsetree.pmtd_name = pmtd_name; - From.Parsetree.pmtd_type = pmtd_type; - From.Parsetree.pmtd_attributes = pmtd_attributes; - From.Parsetree.pmtd_loc = pmtd_loc } - -> - { - To.Parsetree.pmtd_name = - (copy_loc (fun x -> x) pmtd_name); - To.Parsetree.pmtd_type = - (copy_option copy_module_type pmtd_type); - To.Parsetree.pmtd_attributes = - (copy_attributes pmtd_attributes); - To.Parsetree.pmtd_loc = - (copy_location pmtd_loc) - } - -and copy_module_declaration : - From.Parsetree.module_declaration -> - To.Parsetree.module_declaration - = - fun - { From.Parsetree.pmd_name = pmd_name; - From.Parsetree.pmd_type = pmd_type; - From.Parsetree.pmd_attributes = pmd_attributes; - From.Parsetree.pmd_loc = pmd_loc } - -> - { - To.Parsetree.pmd_name = - (copy_loc (fun x -> x) pmd_name); - To.Parsetree.pmd_type = - (copy_module_type pmd_type); - To.Parsetree.pmd_attributes = - (copy_attributes pmd_attributes); - To.Parsetree.pmd_loc = - (copy_location pmd_loc) - } - -and copy_type_extension : - From.Parsetree.type_extension -> - To.Parsetree.type_extension - = - fun - { From.Parsetree.ptyext_path = ptyext_path; - From.Parsetree.ptyext_params = ptyext_params; - From.Parsetree.ptyext_constructors = ptyext_constructors; - From.Parsetree.ptyext_private = ptyext_private; - From.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - To.Parsetree.ptyext_path = - (copy_loc copy_longident - ptyext_path); - To.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptyext_params); - To.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor - ptyext_constructors); - To.Parsetree.ptyext_private = - (copy_private_flag ptyext_private); - To.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } - -and copy_extension_constructor : - From.Parsetree.extension_constructor -> - To.Parsetree.extension_constructor - = - fun - { From.Parsetree.pext_name = pext_name; - From.Parsetree.pext_kind = pext_kind; - From.Parsetree.pext_loc = pext_loc; - From.Parsetree.pext_attributes = pext_attributes } - -> - { - To.Parsetree.pext_name = - (copy_loc (fun x -> x) pext_name); - To.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - To.Parsetree.pext_loc = - (copy_location pext_loc); - To.Parsetree.pext_attributes = - (copy_attributes pext_attributes) - } - -and copy_extension_constructor_kind : - From.Parsetree.extension_constructor_kind -> - To.Parsetree.extension_constructor_kind - = - function - | From.Parsetree.Pext_decl (x0,x1) -> - To.Parsetree.Pext_decl - ((copy_constructor_arguments x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pext_rebind x0 -> - To.Parsetree.Pext_rebind - (copy_loc copy_longident - x0) - -and copy_type_declaration : - From.Parsetree.type_declaration -> - To.Parsetree.type_declaration +let rec copy_out_type_extension : + Ast_404.Outcometree.out_type_extension -> + Ast_403.Outcometree.out_type_extension = fun - { From.Parsetree.ptype_name = ptype_name; - From.Parsetree.ptype_params = ptype_params; - From.Parsetree.ptype_cstrs = ptype_cstrs; - From.Parsetree.ptype_kind = ptype_kind; - From.Parsetree.ptype_private = ptype_private; - From.Parsetree.ptype_manifest = ptype_manifest; - From.Parsetree.ptype_attributes = ptype_attributes; - From.Parsetree.ptype_loc = ptype_loc } - -> + { Ast_404.Outcometree.otyext_name = otyext_name; + Ast_404.Outcometree.otyext_params = otyext_params; + Ast_404.Outcometree.otyext_constructors = otyext_constructors; + Ast_404.Outcometree.otyext_private = otyext_private } + -> { - To.Parsetree.ptype_name = - (copy_loc (fun x -> x) ptype_name); - To.Parsetree.ptype_params = + Ast_403.Outcometree.otyext_name = otyext_name; + Ast_403.Outcometree.otyext_params = + (List.map (fun x -> x) otyext_params); + Ast_403.Outcometree.otyext_constructors = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptype_params); - To.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0,x1,x2) = x in - ((copy_core_type x0), - (copy_core_type x1), - (copy_location x2))) ptype_cstrs); - To.Parsetree.ptype_kind = - (copy_type_kind ptype_kind); - To.Parsetree.ptype_private = - (copy_private_flag ptype_private); - To.Parsetree.ptype_manifest = - (copy_option copy_core_type ptype_manifest); - To.Parsetree.ptype_attributes = - (copy_attributes ptype_attributes); - To.Parsetree.ptype_loc = - (copy_location ptype_loc) - } - -and copy_private_flag : - From.Asttypes.private_flag -> - To.Asttypes.private_flag - = - function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - -and copy_type_kind : - From.Parsetree.type_kind -> - To.Parsetree.type_kind - = - function - | From.Parsetree.Ptype_abstract -> - To.Parsetree.Ptype_abstract - | From.Parsetree.Ptype_variant x0 -> - To.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | From.Parsetree.Ptype_record x0 -> - To.Parsetree.Ptype_record - (List.map copy_label_declaration x0) - | From.Parsetree.Ptype_open -> - To.Parsetree.Ptype_open - -and copy_constructor_declaration : - From.Parsetree.constructor_declaration -> - To.Parsetree.constructor_declaration - = - fun - { From.Parsetree.pcd_name = pcd_name; - From.Parsetree.pcd_args = pcd_args; - From.Parsetree.pcd_res = pcd_res; - From.Parsetree.pcd_loc = pcd_loc; - From.Parsetree.pcd_attributes = pcd_attributes } - -> - { - To.Parsetree.pcd_name = - (copy_loc (fun x -> x) pcd_name); - To.Parsetree.pcd_args = - (copy_constructor_arguments pcd_args); - To.Parsetree.pcd_res = - (copy_option copy_core_type pcd_res); - To.Parsetree.pcd_loc = - (copy_location pcd_loc); - To.Parsetree.pcd_attributes = - (copy_attributes pcd_attributes) - } - -and copy_constructor_arguments : - From.Parsetree.constructor_arguments -> - To.Parsetree.constructor_arguments - = - function - | From.Parsetree.Pcstr_tuple x0 -> - To.Parsetree.Pcstr_tuple - (List.map copy_core_type x0) - | From.Parsetree.Pcstr_record x0 -> - To.Parsetree.Pcstr_record - (List.map copy_label_declaration x0) - -and copy_label_declaration : - From.Parsetree.label_declaration -> - To.Parsetree.label_declaration - = - fun - { From.Parsetree.pld_name = pld_name; - From.Parsetree.pld_mutable = pld_mutable; - From.Parsetree.pld_type = pld_type; - From.Parsetree.pld_loc = pld_loc; - From.Parsetree.pld_attributes = pld_attributes } - -> - { - To.Parsetree.pld_name = - (copy_loc (fun x -> x) pld_name); - To.Parsetree.pld_mutable = - (copy_mutable_flag pld_mutable); - To.Parsetree.pld_type = - (copy_core_type pld_type); - To.Parsetree.pld_loc = - (copy_location pld_loc); - To.Parsetree.pld_attributes = - (copy_attributes pld_attributes) - } - -and copy_mutable_flag : - From.Asttypes.mutable_flag -> - To.Asttypes.mutable_flag - = - function - | From.Asttypes.Immutable -> - To.Asttypes.Immutable - | From.Asttypes.Mutable -> To.Asttypes.Mutable - -and copy_variance : - From.Asttypes.variance -> To.Asttypes.variance = - function - | From.Asttypes.Covariant -> - To.Asttypes.Covariant - | From.Asttypes.Contravariant -> - To.Asttypes.Contravariant - | From.Asttypes.Invariant -> - To.Asttypes.Invariant - -and copy_value_description : - From.Parsetree.value_description -> - To.Parsetree.value_description - = - fun - { From.Parsetree.pval_name = pval_name; - From.Parsetree.pval_type = pval_type; - From.Parsetree.pval_prim = pval_prim; - From.Parsetree.pval_attributes = pval_attributes; - From.Parsetree.pval_loc = pval_loc } - -> - { - To.Parsetree.pval_name = - (copy_loc (fun x -> x) pval_name); - To.Parsetree.pval_type = - (copy_core_type pval_type); - To.Parsetree.pval_prim = - (List.map (fun x -> x) pval_prim); - To.Parsetree.pval_attributes = - (copy_attributes pval_attributes); - To.Parsetree.pval_loc = - (copy_location pval_loc) - } - -and copy_arg_label : - From.Asttypes.arg_label -> To.Asttypes.arg_label - = - function - | From.Asttypes.Nolabel -> To.Asttypes.Nolabel - | From.Asttypes.Labelled x0 -> - To.Asttypes.Labelled x0 - | From.Asttypes.Optional x0 -> - To.Asttypes.Optional x0 - -and copy_closed_flag : - From.Asttypes.closed_flag -> - To.Asttypes.closed_flag - = - function - | From.Asttypes.Closed -> To.Asttypes.Closed - | From.Asttypes.Open -> To.Asttypes.Open - -and copy_label : - From.Asttypes.label -> To.Asttypes.label = - fun x -> x - -and copy_rec_flag : - From.Asttypes.rec_flag -> To.Asttypes.rec_flag = - function - | From.Asttypes.Nonrecursive -> - To.Asttypes.Nonrecursive - | From.Asttypes.Recursive -> - To.Asttypes.Recursive - -and copy_constant : - From.Parsetree.constant -> To.Parsetree.constant - = - function - | From.Parsetree.Pconst_integer (x0,x1) -> - To.Parsetree.Pconst_integer - (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_char x0 -> - To.Parsetree.Pconst_char x0 - | From.Parsetree.Pconst_string (x0,x1) -> - To.Parsetree.Pconst_string - (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_float (x0,x1) -> - To.Parsetree.Pconst_float - (x0, (copy_option (fun x -> x) x1)) - -and copy_option : 'f0 'g0 . ('f0 -> 'g0) -> 'f0 option -> 'g0 option = - fun f0 -> function | None -> None | Some x0 -> Some (f0 x0) - -and copy_longident : - From.Longident.t -> To.Longident.t = - function - | From.Longident.Lident x0 -> - To.Longident.Lident x0 - | From.Longident.Ldot (x0,x1) -> - To.Longident.Ldot - ((copy_longident x0), x1) - | From.Longident.Lapply (x0,x1) -> - To.Longident.Lapply - ((copy_longident x0), (copy_longident x1)) - -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc - = - fun f0 -> - fun - { From.Asttypes.txt = txt; - From.Asttypes.loc = loc } - -> - { - To.Asttypes.txt = (f0 txt); - To.Asttypes.loc = (copy_location loc) - } - -and copy_location : - From.Location.t -> To.Location.t = - fun - { From.Location.loc_start = loc_start; - From.Location.loc_end = loc_end; - From.Location.loc_ghost = loc_ghost } - -> - { - To.Location.loc_start = (copy_Lexing_position loc_start); - To.Location.loc_end = (copy_Lexing_position loc_end); - To.Location.loc_ghost = (copy_bool loc_ghost) - } - -and copy_bool : bool -> bool = function | false -> false | true -> true - -and copy_Lexing_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum + (fun x -> + let (x0, x1, x2) = x in + (x0, (List.map copy_out_type x1), + (Option.map copy_out_type x2))) otyext_constructors); + Ast_403.Outcometree.otyext_private = (copy_private_flag otyext_private) } - -let rec copy_out_phrase : - From.Outcometree.out_phrase -> To.Outcometree.out_phrase = +and copy_out_phrase : + Ast_404.Outcometree.out_phrase -> Ast_403.Outcometree.out_phrase = function - | From.Outcometree.Ophr_eval (x0,x1) -> - To.Outcometree.Ophr_eval - ((copy_out_value x0), - (copy_out_type x1)) - | From.Outcometree.Ophr_signature x0 -> - To.Outcometree.Ophr_signature + | Ast_404.Outcometree.Ophr_eval (x0, x1) -> + Ast_403.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1)) + | Ast_404.Outcometree.Ophr_signature x0 -> + Ast_403.Outcometree.Ophr_signature (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_sig_item x0), - (copy_option copy_out_value x1))) x0) - | From.Outcometree.Ophr_exception x0 -> - To.Outcometree.Ophr_exception - (let (x0,x1) = x0 in - ((copy_exn x0), (copy_out_value x1))) - -and copy_exn : exn -> exn = fun x -> x - + (fun x -> + let (x0, x1) = x in + ((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0) + | Ast_404.Outcometree.Ophr_exception x0 -> + Ast_403.Outcometree.Ophr_exception + (let (x0, x1) = x0 in (x0, (copy_out_value x1))) and copy_out_sig_item : - From.Outcometree.out_sig_item -> To.Outcometree.out_sig_item = + Ast_404.Outcometree.out_sig_item -> Ast_403.Outcometree.out_sig_item = function - | From.Outcometree.Osig_class (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class - ((copy_bool x0), x1, + | Ast_404.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> + Ast_403.Outcometree.Osig_class + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_class_type (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class_type - ((copy_bool x0), x1, + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_404.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> + Ast_403.Outcometree.Osig_class_type + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_typext (x0,x1) -> - To.Outcometree.Osig_typext - ((copy_out_extension_constructor x0), - (copy_out_ext_status x1)) - | From.Outcometree.Osig_modtype (x0,x1) -> - To.Outcometree.Osig_modtype - (x0, (copy_out_module_type x1)) - | From.Outcometree.Osig_module (x0,x1,x2) -> - To.Outcometree.Osig_module - (x0, (copy_out_module_type x1), - (copy_out_rec_status x2)) - | From.Outcometree.Osig_type (x0,x1) -> - To.Outcometree.Osig_type - ((copy_out_type_decl x0), - (copy_out_rec_status x1)) - | From.Outcometree.Osig_value x0 -> - To.Outcometree.Osig_value - (copy_out_val_decl x0) - | From.Outcometree.Osig_ellipsis -> To.Outcometree.Osig_ellipsis - + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_404.Outcometree.Osig_typext (x0, x1) -> + Ast_403.Outcometree.Osig_typext + ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) + | Ast_404.Outcometree.Osig_modtype (x0, x1) -> + Ast_403.Outcometree.Osig_modtype (x0, (copy_out_module_type x1)) + | Ast_404.Outcometree.Osig_module (x0, x1, x2) -> + Ast_403.Outcometree.Osig_module + (x0, (copy_out_module_type x1), (copy_out_rec_status x2)) + | Ast_404.Outcometree.Osig_type (x0, x1) -> + Ast_403.Outcometree.Osig_type + ((copy_out_type_decl x0), (copy_out_rec_status x1)) + | Ast_404.Outcometree.Osig_value x0 -> + Ast_403.Outcometree.Osig_value (copy_out_val_decl x0) + | Ast_404.Outcometree.Osig_ellipsis -> Ast_403.Outcometree.Osig_ellipsis and copy_out_val_decl : - From.Outcometree.out_val_decl -> To.Outcometree.out_val_decl = + Ast_404.Outcometree.out_val_decl -> Ast_403.Outcometree.out_val_decl = fun - { From.Outcometree.oval_name = oval_name; - From.Outcometree.oval_type = oval_type; - From.Outcometree.oval_prims = oval_prims; - From.Outcometree.oval_attributes = oval_attributes } - -> + { Ast_404.Outcometree.oval_name = oval_name; + Ast_404.Outcometree.oval_type = oval_type; + Ast_404.Outcometree.oval_prims = oval_prims; + Ast_404.Outcometree.oval_attributes = oval_attributes } + -> { - To.Outcometree.oval_name = oval_name; - To.Outcometree.oval_type = - (copy_out_type oval_type); - To.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); - To.Outcometree.oval_attributes = + Ast_403.Outcometree.oval_name = oval_name; + Ast_403.Outcometree.oval_type = (copy_out_type oval_type); + Ast_403.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); + Ast_403.Outcometree.oval_attributes = (List.map copy_out_attribute oval_attributes) } +and copy_From_Asttypes_private_flag : + From.Asttypes.private_flag -> To.Asttypes.private_flag = + function + | From.Asttypes.Private -> To.Asttypes.Private + | From.Asttypes.Public -> To.Asttypes.Public + and copy_out_type_decl : From.Outcometree.out_type_decl -> To.Outcometree.out_type_decl = fun @@ -1617,13 +107,13 @@ and copy_out_type_decl : (List.map (fun x -> let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) + (x0, (let (x0,x1) = x1 in (x0, x1)))) otype_params); To.Outcometree.otype_type = (copy_out_type otype_type); To.Outcometree.otype_private = (copy_From_Asttypes_private_flag otype_private); - To.Outcometree.otype_immediate = (copy_bool otype_immediate); + To.Outcometree.otype_immediate = otype_immediate; To.Outcometree.otype_cstrs = (List.map (fun x -> @@ -1631,286 +121,190 @@ and copy_out_type_decl : ((copy_out_type x0), (copy_out_type x1))) otype_cstrs) } - and copy_out_module_type : - From.Outcometree.out_module_type -> To.Outcometree.out_module_type - = - function - | From.Outcometree.Omty_abstract -> To.Outcometree.Omty_abstract - | From.Outcometree.Omty_functor (x0,x1,x2) -> - To.Outcometree.Omty_functor - (x0, (copy_option copy_out_module_type x1), - (copy_out_module_type x2)) - | From.Outcometree.Omty_ident x0 -> - To.Outcometree.Omty_ident (copy_out_ident x0) - | From.Outcometree.Omty_signature x0 -> - To.Outcometree.Omty_signature - (List.map copy_out_sig_item x0) - | From.Outcometree.Omty_alias x0 -> - To.Outcometree.Omty_alias (copy_out_ident x0) - + Ast_404.Outcometree.out_module_type -> Ast_403.Outcometree.out_module_type + = + function + | Ast_404.Outcometree.Omty_abstract -> Ast_403.Outcometree.Omty_abstract + | Ast_404.Outcometree.Omty_functor (x0, x1, x2) -> + Ast_403.Outcometree.Omty_functor + (x0, (Option.map copy_out_module_type x1), (copy_out_module_type x2)) + | Ast_404.Outcometree.Omty_ident x0 -> + Ast_403.Outcometree.Omty_ident (copy_out_ident x0) + | Ast_404.Outcometree.Omty_signature x0 -> + Ast_403.Outcometree.Omty_signature (List.map copy_out_sig_item x0) + | Ast_404.Outcometree.Omty_alias x0 -> + Ast_403.Outcometree.Omty_alias (copy_out_ident x0) and copy_out_ext_status : - From.Outcometree.out_ext_status -> To.Outcometree.out_ext_status = + Ast_404.Outcometree.out_ext_status -> Ast_403.Outcometree.out_ext_status = function - | From.Outcometree.Oext_first -> To.Outcometree.Oext_first - | From.Outcometree.Oext_next -> To.Outcometree.Oext_next - | From.Outcometree.Oext_exception -> To.Outcometree.Oext_exception - + | Ast_404.Outcometree.Oext_first -> Ast_403.Outcometree.Oext_first + | Ast_404.Outcometree.Oext_next -> Ast_403.Outcometree.Oext_next + | Ast_404.Outcometree.Oext_exception -> Ast_403.Outcometree.Oext_exception and copy_out_extension_constructor : - From.Outcometree.out_extension_constructor -> - To.Outcometree.out_extension_constructor + Ast_404.Outcometree.out_extension_constructor -> + Ast_403.Outcometree.out_extension_constructor = fun - { From.Outcometree.oext_name = oext_name; - From.Outcometree.oext_type_name = oext_type_name; - From.Outcometree.oext_type_params = oext_type_params; - From.Outcometree.oext_args = oext_args; - From.Outcometree.oext_ret_type = oext_ret_type; - From.Outcometree.oext_private = oext_private } - -> + { Ast_404.Outcometree.oext_name = oext_name; + Ast_404.Outcometree.oext_type_name = oext_type_name; + Ast_404.Outcometree.oext_type_params = oext_type_params; + Ast_404.Outcometree.oext_args = oext_args; + Ast_404.Outcometree.oext_ret_type = oext_ret_type; + Ast_404.Outcometree.oext_private = oext_private } + -> { - To.Outcometree.oext_name = oext_name; - To.Outcometree.oext_type_name = oext_type_name; - To.Outcometree.oext_type_params = - (List.map (fun x -> x) oext_type_params); - To.Outcometree.oext_args = - (List.map copy_out_type oext_args); - To.Outcometree.oext_ret_type = - (copy_option copy_out_type oext_ret_type); - To.Outcometree.oext_private = - (copy_From_Asttypes_private_flag oext_private) + Ast_403.Outcometree.oext_name = oext_name; + Ast_403.Outcometree.oext_type_name = oext_type_name; + Ast_403.Outcometree.oext_type_params = + (List.map (fun x -> x) oext_type_params); + Ast_403.Outcometree.oext_args = (List.map copy_out_type oext_args); + Ast_403.Outcometree.oext_ret_type = + (Option.map copy_out_type oext_ret_type); + Ast_403.Outcometree.oext_private = (copy_private_flag oext_private) } - -and copy_From_Asttypes_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = +and copy_private_flag : + Ast_404.Asttypes.private_flag -> Ast_403.Asttypes.private_flag = function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - + | Ast_404.Asttypes.Private -> Ast_403.Asttypes.Private + | Ast_404.Asttypes.Public -> Ast_403.Asttypes.Public and copy_out_rec_status : - From.Outcometree.out_rec_status -> To.Outcometree.out_rec_status = + Ast_404.Outcometree.out_rec_status -> Ast_403.Outcometree.out_rec_status = function - | From.Outcometree.Orec_not -> To.Outcometree.Orec_not - | From.Outcometree.Orec_first -> To.Outcometree.Orec_first - | From.Outcometree.Orec_next -> To.Outcometree.Orec_next - + | Ast_404.Outcometree.Orec_not -> Ast_403.Outcometree.Orec_not + | Ast_404.Outcometree.Orec_first -> Ast_403.Outcometree.Orec_first + | Ast_404.Outcometree.Orec_next -> Ast_403.Outcometree.Orec_next and copy_out_class_type : - From.Outcometree.out_class_type -> To.Outcometree.out_class_type = - function - | From.Outcometree.Octy_constr (x0,x1) -> - To.Outcometree.Octy_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Octy_arrow (x0,x1,x2) -> - To.Outcometree.Octy_arrow - (x0, (copy_out_type x1), - (copy_out_class_type x2)) - | From.Outcometree.Octy_signature (x0,x1) -> - To.Outcometree.Octy_signature - ((copy_option copy_out_type x0), + Ast_404.Outcometree.out_class_type -> Ast_403.Outcometree.out_class_type = + function + | Ast_404.Outcometree.Octy_constr (x0, x1) -> + Ast_403.Outcometree.Octy_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_404.Outcometree.Octy_arrow (x0, x1, x2) -> + Ast_403.Outcometree.Octy_arrow + (x0, (copy_out_type x1), (copy_out_class_type x2)) + | Ast_404.Outcometree.Octy_signature (x0, x1) -> + Ast_403.Outcometree.Octy_signature + ((Option.map copy_out_type x0), (List.map copy_out_class_sig_item x1)) - and copy_out_class_sig_item : - From.Outcometree.out_class_sig_item -> - To.Outcometree.out_class_sig_item + Ast_404.Outcometree.out_class_sig_item -> + Ast_403.Outcometree.out_class_sig_item = function - | From.Outcometree.Ocsg_constraint (x0,x1) -> - To.Outcometree.Ocsg_constraint - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Ocsg_method (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_method - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - | From.Outcometree.Ocsg_value (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_value - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - + | Ast_404.Outcometree.Ocsg_constraint (x0, x1) -> + Ast_403.Outcometree.Ocsg_constraint + ((copy_out_type x0), (copy_out_type x1)) + | Ast_404.Outcometree.Ocsg_method (x0, x1, x2, x3) -> + Ast_403.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3)) + | Ast_404.Outcometree.Ocsg_value (x0, x1, x2, x3) -> + Ast_403.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3)) and copy_out_type : - From.Outcometree.out_type -> To.Outcometree.out_type = - function - | From.Outcometree.Otyp_abstract -> To.Outcometree.Otyp_abstract - | From.Outcometree.Otyp_open -> To.Outcometree.Otyp_open - | From.Outcometree.Otyp_alias (x0,x1) -> - To.Outcometree.Otyp_alias - ((copy_out_type x0), x1) - | From.Outcometree.Otyp_arrow (x0,x1,x2) -> - To.Outcometree.Otyp_arrow - (x0, (copy_out_type x1), - (copy_out_type x2)) - | From.Outcometree.Otyp_class (x0,x1,x2) -> - To.Outcometree.Otyp_class - ((copy_bool x0), (copy_out_ident x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_constr (x0,x1) -> - To.Outcometree.Otyp_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Otyp_manifest (x0,x1) -> - To.Outcometree.Otyp_manifest - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Otyp_object (x0,x1) -> - To.Outcometree.Otyp_object - ((List.map - (fun x -> - let (x0,x1) = x in - (x0, (copy_out_type x1))) x0), - (copy_option copy_bool x1)) - | From.Outcometree.Otyp_record x0 -> - To.Outcometree.Otyp_record + Ast_404.Outcometree.out_type -> Ast_403.Outcometree.out_type = + function + | Ast_404.Outcometree.Otyp_abstract -> Ast_403.Outcometree.Otyp_abstract + | Ast_404.Outcometree.Otyp_open -> Ast_403.Outcometree.Otyp_open + | Ast_404.Outcometree.Otyp_alias (x0, x1) -> + Ast_403.Outcometree.Otyp_alias ((copy_out_type x0), x1) + | Ast_404.Outcometree.Otyp_arrow (x0, x1, x2) -> + Ast_403.Outcometree.Otyp_arrow + (x0, (copy_out_type x1), (copy_out_type x2)) + | Ast_404.Outcometree.Otyp_class (x0, x1, x2) -> + Ast_403.Outcometree.Otyp_class + (x0, (copy_out_ident x1), (List.map copy_out_type x2)) + | Ast_404.Outcometree.Otyp_constr (x0, x1) -> + Ast_403.Outcometree.Otyp_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_404.Outcometree.Otyp_manifest (x0, x1) -> + Ast_403.Outcometree.Otyp_manifest + ((copy_out_type x0), (copy_out_type x1)) + | Ast_404.Outcometree.Otyp_object (x0, x1) -> + Ast_403.Outcometree.Otyp_object + ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0), + (Option.map (fun x -> x) x1)) + | Ast_404.Outcometree.Otyp_record x0 -> + Ast_403.Outcometree.Otyp_record (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), (copy_out_type x2))) - x0) - | From.Outcometree.Otyp_stuff x0 -> To.Outcometree.Otyp_stuff x0 - | From.Outcometree.Otyp_sum x0 -> - To.Outcometree.Otyp_sum + (fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0) + | Ast_404.Outcometree.Otyp_stuff x0 -> Ast_403.Outcometree.Otyp_stuff x0 + | Ast_404.Outcometree.Otyp_sum x0 -> + Ast_403.Outcometree.Otyp_sum (List.map - (fun x -> - let (x0,x1,x2) = x in + (fun x -> + let (x0, x1, x2) = x in (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) x0) - | From.Outcometree.Otyp_tuple x0 -> - To.Outcometree.Otyp_tuple - (List.map copy_out_type x0) - | From.Outcometree.Otyp_var (x0,x1) -> - To.Outcometree.Otyp_var ((copy_bool x0), x1) - | From.Outcometree.Otyp_variant (x0,x1,x2,x3) -> - To.Outcometree.Otyp_variant - ((copy_bool x0), (copy_out_variant x1), - (copy_bool x2), - (copy_option (fun x -> List.map (fun x -> x) x) x3)) - | From.Outcometree.Otyp_poly (x0,x1) -> - To.Outcometree.Otyp_poly - ((List.map (fun x -> x) x0), (copy_out_type x1)) - | From.Outcometree.Otyp_module (x0,x1,x2) -> - To.Outcometree.Otyp_module - (x0, (List.map (fun x -> x) x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_attribute (x0,x1) -> - To.Outcometree.Otyp_attribute - ((copy_out_type x0), - (copy_out_attribute x1)) - + (Option.map copy_out_type x2))) x0) + | Ast_404.Outcometree.Otyp_tuple x0 -> + Ast_403.Outcometree.Otyp_tuple (List.map copy_out_type x0) + | Ast_404.Outcometree.Otyp_var (x0, x1) -> + Ast_403.Outcometree.Otyp_var (x0, x1) + | Ast_404.Outcometree.Otyp_variant (x0, x1, x2, x3) -> + Ast_403.Outcometree.Otyp_variant + (x0, (copy_out_variant x1), x2, + (Option.map (fun x -> List.map (fun x -> x) x) x3)) + | Ast_404.Outcometree.Otyp_poly (x0, x1) -> + Ast_403.Outcometree.Otyp_poly + ((List.map (fun x -> x) x0), (copy_out_type x1)) + | Ast_404.Outcometree.Otyp_module (x0, x1, x2) -> + Ast_403.Outcometree.Otyp_module + (x0, (List.map (fun x -> x) x1), (List.map copy_out_type x2)) + | Ast_404.Outcometree.Otyp_attribute (x0, x1) -> + Ast_403.Outcometree.Otyp_attribute + ((copy_out_type x0), (copy_out_attribute x1)) and copy_out_attribute : - From.Outcometree.out_attribute -> To.Outcometree.out_attribute = - fun { From.Outcometree.oattr_name = oattr_name } -> - { To.Outcometree.oattr_name = oattr_name } - + Ast_404.Outcometree.out_attribute -> Ast_403.Outcometree.out_attribute = + fun { Ast_404.Outcometree.oattr_name = oattr_name } -> + { Ast_403.Outcometree.oattr_name = oattr_name } and copy_out_variant : - From.Outcometree.out_variant -> To.Outcometree.out_variant = + Ast_404.Outcometree.out_variant -> Ast_403.Outcometree.out_variant = function - | From.Outcometree.Ovar_fields x0 -> - To.Outcometree.Ovar_fields + | Ast_404.Outcometree.Ovar_fields x0 -> + Ast_403.Outcometree.Ovar_fields (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), - (List.map copy_out_type x2))) x0) - | From.Outcometree.Ovar_name (x0,x1) -> - To.Outcometree.Ovar_name - ((copy_out_ident x0), - (List.map copy_out_type x1)) - + (fun x -> + let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2))) + x0) + | Ast_404.Outcometree.Ovar_name (x0, x1) -> + Ast_403.Outcometree.Ovar_name + ((copy_out_ident x0), (List.map copy_out_type x1)) and copy_out_value : - From.Outcometree.out_value -> To.Outcometree.out_value = - function - | From.Outcometree.Oval_array x0 -> - To.Outcometree.Oval_array - (List.map copy_out_value x0) - | From.Outcometree.Oval_char x0 -> To.Outcometree.Oval_char x0 - | From.Outcometree.Oval_constr (x0,x1) -> - To.Outcometree.Oval_constr - ((copy_out_ident x0), - (List.map copy_out_value x1)) - | From.Outcometree.Oval_ellipsis -> To.Outcometree.Oval_ellipsis - | From.Outcometree.Oval_float x0 -> - To.Outcometree.Oval_float (copy_float x0) - | From.Outcometree.Oval_int x0 -> To.Outcometree.Oval_int x0 - | From.Outcometree.Oval_int32 x0 -> To.Outcometree.Oval_int32 x0 - | From.Outcometree.Oval_int64 x0 -> To.Outcometree.Oval_int64 x0 - | From.Outcometree.Oval_nativeint x0 -> - To.Outcometree.Oval_nativeint x0 - | From.Outcometree.Oval_list x0 -> - To.Outcometree.Oval_list - (List.map copy_out_value x0) - | From.Outcometree.Oval_printer x0 -> - To.Outcometree.Oval_printer x0 - | From.Outcometree.Oval_record x0 -> - To.Outcometree.Oval_record + Ast_404.Outcometree.out_value -> Ast_403.Outcometree.out_value = + function + | Ast_404.Outcometree.Oval_array x0 -> + Ast_403.Outcometree.Oval_array (List.map copy_out_value x0) + | Ast_404.Outcometree.Oval_char x0 -> Ast_403.Outcometree.Oval_char x0 + | Ast_404.Outcometree.Oval_constr (x0, x1) -> + Ast_403.Outcometree.Oval_constr + ((copy_out_ident x0), (List.map copy_out_value x1)) + | Ast_404.Outcometree.Oval_ellipsis -> Ast_403.Outcometree.Oval_ellipsis + | Ast_404.Outcometree.Oval_float x0 -> Ast_403.Outcometree.Oval_float x0 + | Ast_404.Outcometree.Oval_int x0 -> Ast_403.Outcometree.Oval_int x0 + | Ast_404.Outcometree.Oval_int32 x0 -> Ast_403.Outcometree.Oval_int32 x0 + | Ast_404.Outcometree.Oval_int64 x0 -> Ast_403.Outcometree.Oval_int64 x0 + | Ast_404.Outcometree.Oval_nativeint x0 -> + Ast_403.Outcometree.Oval_nativeint x0 + | Ast_404.Outcometree.Oval_list x0 -> + Ast_403.Outcometree.Oval_list (List.map copy_out_value x0) + | Ast_404.Outcometree.Oval_printer x0 -> + Ast_403.Outcometree.Oval_printer x0 + | Ast_404.Outcometree.Oval_record x0 -> + Ast_403.Outcometree.Oval_record (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_ident x0), - (copy_out_value x1))) x0) - | From.Outcometree.Oval_string x0 -> To.Outcometree.Oval_string x0 - | From.Outcometree.Oval_stuff x0 -> To.Outcometree.Oval_stuff x0 - | From.Outcometree.Oval_tuple x0 -> - To.Outcometree.Oval_tuple - (List.map copy_out_value x0) - | From.Outcometree.Oval_variant (x0,x1) -> - To.Outcometree.Oval_variant - (x0, (copy_option copy_out_value x1)) - -and copy_float : float -> float = fun x -> x - + (fun x -> + let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1))) + x0) + | Ast_404.Outcometree.Oval_string x0 -> Ast_403.Outcometree.Oval_string x0 + | Ast_404.Outcometree.Oval_stuff x0 -> Ast_403.Outcometree.Oval_stuff x0 + | Ast_404.Outcometree.Oval_tuple x0 -> + Ast_403.Outcometree.Oval_tuple (List.map copy_out_value x0) + | Ast_404.Outcometree.Oval_variant (x0, x1) -> + Ast_403.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1)) and copy_out_ident : - From.Outcometree.out_ident -> To.Outcometree.out_ident = - function - | From.Outcometree.Oide_apply (x0,x1) -> - To.Outcometree.Oide_apply ((copy_out_ident x0), (copy_out_ident x1)) - | From.Outcometree.Oide_dot (x0,x1) -> - To.Outcometree.Oide_dot ((copy_out_ident x0), x1) - | From.Outcometree.Oide_ident x0 -> To.Outcometree.Oide_ident x0 - -let rec copy_toplevel_phrase : - From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = - function - | From.Parsetree.Ptop_def x0 -> - To.Parsetree.Ptop_def (copy_structure x0) - | From.Parsetree.Ptop_dir (x0,x1) -> - To.Parsetree.Ptop_dir (x0, (copy_directive_argument x1)) - -and copy_directive_argument : - From.Parsetree.directive_argument -> To.Parsetree.directive_argument = - function - | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none - | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 - | From.Parsetree.Pdir_int (x0,x1) -> - To.Parsetree.Pdir_int (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pdir_ident x0 -> - To.Parsetree.Pdir_ident (copy_longident x0) - | From.Parsetree.Pdir_bool x0 -> - To.Parsetree.Pdir_bool (copy_bool x0) - -let copy_out_type_extension : - From.Outcometree.out_type_extension -> To.Outcometree.out_type_extension = - fun - { From.Outcometree.otyext_name = otyext_name; - From.Outcometree.otyext_params = otyext_params; - From.Outcometree.otyext_constructors = otyext_constructors; - From.Outcometree.otyext_private = otyext_private } - -> - { - To.Outcometree.otyext_name = otyext_name; - To.Outcometree.otyext_params = - (List.map (fun x -> x) otyext_params); - To.Outcometree.otyext_constructors = - (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) - otyext_constructors); - To.Outcometree.otyext_private = - (copy_private_flag otyext_private) - } - -let copy_cases x = List.map copy_case x -let copy_pat = copy_pattern -let copy_expr = copy_expression -let copy_typ = copy_core_type + Ast_404.Outcometree.out_ident -> Ast_403.Outcometree.out_ident = + function + | Ast_404.Outcometree.Oide_apply (x0, x1) -> + Ast_403.Outcometree.Oide_apply + ((copy_out_ident x0), (copy_out_ident x1)) + | Ast_404.Outcometree.Oide_dot (x0, x1) -> + Ast_403.Outcometree.Oide_dot ((copy_out_ident x0), x1) + | Ast_404.Outcometree.Oide_ident x0 -> Ast_403.Outcometree.Oide_ident x0 diff --git a/src/vendored-omp/src/migrate_parsetree_404_405.ml b/src/vendored-omp/src/migrate_parsetree_404_405.ml index ad6594ee6..268102952 100644 --- a/src/vendored-omp/src/migrate_parsetree_404_405.ml +++ b/src/vendored-omp/src/migrate_parsetree_404_405.ml @@ -15,116 +15,3 @@ include Migrate_parsetree_404_405_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - (*$*) - } as mapper) -> - let module R = Migrate_parsetree_405_404_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_404_405_migrate.ml b/src/vendored-omp/src/migrate_parsetree_404_405_migrate.ml index d62423a8d..2f188a237 100644 --- a/src/vendored-omp/src/migrate_parsetree_404_405_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_404_405_migrate.ml @@ -1,1716 +1,302 @@ -(**************************************************************************) -(* *) -(* OCaml Migrate Parsetree *) -(* *) -(* Frédéric Bour *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2017 Institut National de Recherche en Informatique et *) -(* en Automatique (INRIA). *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - +open Stdlib0 module From = Ast_404 module To = Ast_405 - -let noloc x = { Location. txt = x; loc = Location.none } - -let rec copy_expression : - From.Parsetree.expression -> To.Parsetree.expression = - fun - { From.Parsetree.pexp_desc = pexp_desc; - From.Parsetree.pexp_loc = pexp_loc; - From.Parsetree.pexp_attributes = pexp_attributes } - -> - { - To.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - To.Parsetree.pexp_loc = (copy_location pexp_loc); - To.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } - -and copy_expression_desc : - From.Parsetree.expression_desc -> To.Parsetree.expression_desc = - function - | From.Parsetree.Pexp_ident x0 -> - To.Parsetree.Pexp_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_constant x0 -> - To.Parsetree.Pexp_constant (copy_constant x0) - | From.Parsetree.Pexp_let (x0,x1,x2) -> - To.Parsetree.Pexp_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_expression x2)) - | From.Parsetree.Pexp_function x0 -> - To.Parsetree.Pexp_function - (List.map copy_case x0) - | From.Parsetree.Pexp_fun (x0,x1,x2,x3) -> - To.Parsetree.Pexp_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_expression x3)) - | From.Parsetree.Pexp_apply (x0,x1) -> - To.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pexp_match (x0,x1) -> - To.Parsetree.Pexp_match - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_try (x0,x1) -> - To.Parsetree.Pexp_try - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_tuple x0 -> - To.Parsetree.Pexp_tuple - (List.map copy_expression x0) - | From.Parsetree.Pexp_construct (x0,x1) -> - To.Parsetree.Pexp_construct - ((copy_loc copy_longident x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_variant (x0,x1) -> - To.Parsetree.Pexp_variant - ((copy_label x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_record (x0,x1) -> - To.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_expression x1))) x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_field (x0,x1) -> - To.Parsetree.Pexp_field - ((copy_expression x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pexp_setfield (x0,x1,x2) -> - To.Parsetree.Pexp_setfield - ((copy_expression x0), - (copy_loc copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_array x0 -> - To.Parsetree.Pexp_array - (List.map copy_expression x0) - | From.Parsetree.Pexp_ifthenelse (x0,x1,x2) -> - To.Parsetree.Pexp_ifthenelse - ((copy_expression x0), - (copy_expression x1), - (copy_option copy_expression x2)) - | From.Parsetree.Pexp_sequence (x0,x1) -> - To.Parsetree.Pexp_sequence - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_while (x0,x1) -> - To.Parsetree.Pexp_while - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_for (x0,x1,x2,x3,x4) -> - To.Parsetree.Pexp_for - ((copy_pattern x0), - (copy_expression x1), - (copy_expression x2), - (copy_direction_flag x3), - (copy_expression x4)) - | From.Parsetree.Pexp_constraint (x0,x1) -> - To.Parsetree.Pexp_constraint - ((copy_expression x0), - (copy_core_type x1)) - | From.Parsetree.Pexp_coerce (x0,x1,x2) -> - To.Parsetree.Pexp_coerce - ((copy_expression x0), - (copy_option copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Pexp_send (x0,x1) -> - To.Parsetree.Pexp_send - ((copy_expression x0), noloc x1) - | From.Parsetree.Pexp_new x0 -> - To.Parsetree.Pexp_new - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_setinstvar (x0,x1) -> - To.Parsetree.Pexp_setinstvar - ((copy_loc (fun x -> x) x0), - (copy_expression x1)) - | From.Parsetree.Pexp_override x0 -> - To.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_expression x1))) x0) - | From.Parsetree.Pexp_letmodule (x0,x1,x2) -> - To.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> x) x0), - (copy_module_expr x1), - (copy_expression x2)) - | From.Parsetree.Pexp_letexception (x0,x1) -> - To.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), - (copy_expression x1)) - | From.Parsetree.Pexp_assert x0 -> - To.Parsetree.Pexp_assert (copy_expression x0) - | From.Parsetree.Pexp_lazy x0 -> - To.Parsetree.Pexp_lazy (copy_expression x0) - | From.Parsetree.Pexp_poly (x0,x1) -> - To.Parsetree.Pexp_poly - ((copy_expression x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pexp_object x0 -> - To.Parsetree.Pexp_object - (copy_class_structure x0) - | From.Parsetree.Pexp_newtype (x0,x1) -> - To.Parsetree.Pexp_newtype - (noloc x0, (copy_expression x1)) - | From.Parsetree.Pexp_pack x0 -> - To.Parsetree.Pexp_pack (copy_module_expr x0) - | From.Parsetree.Pexp_open (x0,x1,x2) -> - To.Parsetree.Pexp_open - ((copy_override_flag x0), - (copy_loc copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_extension x0 -> - To.Parsetree.Pexp_extension (copy_extension x0) - | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable - -and copy_direction_flag : - From.Asttypes.direction_flag -> To.Asttypes.direction_flag = - function - | From.Asttypes.Upto -> To.Asttypes.Upto - | From.Asttypes.Downto -> To.Asttypes.Downto - -and copy_case : - From.Parsetree.case -> To.Parsetree.case = - fun - { From.Parsetree.pc_lhs = pc_lhs; - From.Parsetree.pc_guard = pc_guard; - From.Parsetree.pc_rhs = pc_rhs } - -> - { - To.Parsetree.pc_lhs = (copy_pattern pc_lhs); - To.Parsetree.pc_guard = - (copy_option copy_expression pc_guard); - To.Parsetree.pc_rhs = (copy_expression pc_rhs) - } - -and copy_value_binding : - From.Parsetree.value_binding -> To.Parsetree.value_binding = - fun - { From.Parsetree.pvb_pat = pvb_pat; - From.Parsetree.pvb_expr = pvb_expr; - From.Parsetree.pvb_attributes = pvb_attributes; - From.Parsetree.pvb_loc = pvb_loc } - -> - { - To.Parsetree.pvb_pat = (copy_pattern pvb_pat); - To.Parsetree.pvb_expr = - (copy_expression pvb_expr); - To.Parsetree.pvb_attributes = - (copy_attributes pvb_attributes); - To.Parsetree.pvb_loc = (copy_location pvb_loc) - } - -and copy_pattern : - From.Parsetree.pattern -> To.Parsetree.pattern = - fun - { From.Parsetree.ppat_desc = ppat_desc; - From.Parsetree.ppat_loc = ppat_loc; - From.Parsetree.ppat_attributes = ppat_attributes } - -> - { - To.Parsetree.ppat_desc = - (copy_pattern_desc ppat_desc); - To.Parsetree.ppat_loc = (copy_location ppat_loc); - To.Parsetree.ppat_attributes = - (copy_attributes ppat_attributes) - } - -and copy_pattern_desc : - From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc = - function - | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any - | From.Parsetree.Ppat_var x0 -> - To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_alias (x0,x1) -> - To.Parsetree.Ppat_alias - ((copy_pattern x0), - (copy_loc (fun x -> x) x1)) - | From.Parsetree.Ppat_constant x0 -> - To.Parsetree.Ppat_constant (copy_constant x0) - | From.Parsetree.Ppat_interval (x0,x1) -> - To.Parsetree.Ppat_interval - ((copy_constant x0), - (copy_constant x1)) - | From.Parsetree.Ppat_tuple x0 -> - To.Parsetree.Ppat_tuple - (List.map copy_pattern x0) - | From.Parsetree.Ppat_construct (x0,x1) -> - To.Parsetree.Ppat_construct - ((copy_loc copy_longident x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_variant (x0,x1) -> - To.Parsetree.Ppat_variant - ((copy_label x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_record (x0,x1) -> - To.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ppat_array x0 -> - To.Parsetree.Ppat_array - (List.map copy_pattern x0) - | From.Parsetree.Ppat_or (x0,x1) -> - To.Parsetree.Ppat_or - ((copy_pattern x0), - (copy_pattern x1)) - | From.Parsetree.Ppat_constraint (x0,x1) -> - To.Parsetree.Ppat_constraint - ((copy_pattern x0), - (copy_core_type x1)) - | From.Parsetree.Ppat_type x0 -> - To.Parsetree.Ppat_type - (copy_loc copy_longident x0) - | From.Parsetree.Ppat_lazy x0 -> - To.Parsetree.Ppat_lazy (copy_pattern x0) - | From.Parsetree.Ppat_unpack x0 -> - To.Parsetree.Ppat_unpack - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_exception x0 -> - To.Parsetree.Ppat_exception (copy_pattern x0) - | From.Parsetree.Ppat_extension x0 -> - To.Parsetree.Ppat_extension (copy_extension x0) - | From.Parsetree.Ppat_open (x0,x1) -> - To.Parsetree.Ppat_open - ((copy_loc copy_longident x0), - (copy_pattern x1)) - -and copy_core_type : - From.Parsetree.core_type -> To.Parsetree.core_type = - fun - { From.Parsetree.ptyp_desc = ptyp_desc; - From.Parsetree.ptyp_loc = ptyp_loc; - From.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - To.Parsetree.ptyp_desc = - (copy_core_type_desc ptyp_desc); - To.Parsetree.ptyp_loc = (copy_location ptyp_loc); - To.Parsetree.ptyp_attributes = - (copy_attributes ptyp_attributes) - } - -and copy_core_type_desc : - From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = - function - | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any - | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 - | From.Parsetree.Ptyp_arrow (x0,x1,x2) -> - To.Parsetree.Ptyp_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Ptyp_tuple x0 -> - To.Parsetree.Ptyp_tuple - (List.map copy_core_type x0) - | From.Parsetree.Ptyp_constr (x0,x1) -> - To.Parsetree.Ptyp_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_object (x0,x1) -> - To.Parsetree.Ptyp_object - ((List.map - (fun x -> - let (x0,x1,x2) = x in - (noloc x0, (copy_attributes x1), - (copy_core_type x2))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ptyp_class (x0,x1) -> - To.Parsetree.Ptyp_class - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_alias (x0,x1) -> - To.Parsetree.Ptyp_alias - ((copy_core_type x0), x1) - | From.Parsetree.Ptyp_variant (x0,x1,x2) -> - To.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), - (copy_closed_flag x1), - (copy_option (fun x -> List.map copy_label x) x2)) - | From.Parsetree.Ptyp_poly (x0,x1) -> - To.Parsetree.Ptyp_poly - ((List.map (fun x -> noloc x) x0), (copy_core_type x1)) - | From.Parsetree.Ptyp_package x0 -> - To.Parsetree.Ptyp_package (copy_package_type x0) - | From.Parsetree.Ptyp_extension x0 -> - To.Parsetree.Ptyp_extension (copy_extension x0) - -and copy_package_type : - From.Parsetree.package_type -> To.Parsetree.package_type = - fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_core_type x1))) x1)) - -and copy_row_field : - From.Parsetree.row_field -> To.Parsetree.row_field = - function - | From.Parsetree.Rtag (x0,x1,x2,x3) -> - To.Parsetree.Rtag - ((copy_label x0), - (copy_attributes x1), (copy_bool x2), - (List.map copy_core_type x3)) - | From.Parsetree.Rinherit x0 -> - To.Parsetree.Rinherit (copy_core_type x0) - -and copy_attributes : - From.Parsetree.attributes -> To.Parsetree.attributes = - fun x -> List.map copy_attribute x - -and copy_attribute : - From.Parsetree.attribute -> To.Parsetree.attribute = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_payload : - From.Parsetree.payload -> To.Parsetree.payload = - function - | From.Parsetree.PStr x0 -> - To.Parsetree.PStr (copy_structure x0) - | From.Parsetree.PSig x0 -> - To.Parsetree.PSig (copy_signature x0) - | From.Parsetree.PTyp x0 -> - To.Parsetree.PTyp (copy_core_type x0) - | From.Parsetree.PPat (x0,x1) -> - To.Parsetree.PPat - ((copy_pattern x0), - (copy_option copy_expression x1)) - -and copy_structure : - From.Parsetree.structure -> To.Parsetree.structure = - fun x -> List.map copy_structure_item x - -and copy_structure_item : - From.Parsetree.structure_item -> To.Parsetree.structure_item = - fun - { From.Parsetree.pstr_desc = pstr_desc; - From.Parsetree.pstr_loc = pstr_loc } - -> - { - To.Parsetree.pstr_desc = - (copy_structure_item_desc pstr_desc); - To.Parsetree.pstr_loc = (copy_location pstr_loc) - } - -and copy_structure_item_desc : - From.Parsetree.structure_item_desc -> - To.Parsetree.structure_item_desc - = - function - | From.Parsetree.Pstr_eval (x0,x1) -> - To.Parsetree.Pstr_eval - ((copy_expression x0), - (copy_attributes x1)) - | From.Parsetree.Pstr_value (x0,x1) -> - To.Parsetree.Pstr_value - ((copy_rec_flag x0), - (List.map copy_value_binding x1)) - | From.Parsetree.Pstr_primitive x0 -> - To.Parsetree.Pstr_primitive - (copy_value_description x0) - | From.Parsetree.Pstr_type (x0,x1) -> - To.Parsetree.Pstr_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Pstr_typext x0 -> - To.Parsetree.Pstr_typext - (copy_type_extension x0) - | From.Parsetree.Pstr_exception x0 -> - To.Parsetree.Pstr_exception - (copy_extension_constructor x0) - | From.Parsetree.Pstr_module x0 -> - To.Parsetree.Pstr_module - (copy_module_binding x0) - | From.Parsetree.Pstr_recmodule x0 -> - To.Parsetree.Pstr_recmodule - (List.map copy_module_binding x0) - | From.Parsetree.Pstr_modtype x0 -> - To.Parsetree.Pstr_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Pstr_open x0 -> - To.Parsetree.Pstr_open - (copy_open_description x0) - | From.Parsetree.Pstr_class x0 -> - To.Parsetree.Pstr_class - (List.map copy_class_declaration x0) - | From.Parsetree.Pstr_class_type x0 -> - To.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Pstr_include x0 -> - To.Parsetree.Pstr_include - (copy_include_declaration x0) - | From.Parsetree.Pstr_attribute x0 -> - To.Parsetree.Pstr_attribute (copy_attribute x0) - | From.Parsetree.Pstr_extension (x0,x1) -> - To.Parsetree.Pstr_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_include_declaration : - From.Parsetree.include_declaration -> - To.Parsetree.include_declaration - = - fun x -> - copy_include_infos copy_module_expr x - -and copy_class_declaration : - From.Parsetree.class_declaration -> To.Parsetree.class_declaration - = - fun x -> - copy_class_infos copy_class_expr x - -and copy_class_expr : - From.Parsetree.class_expr -> To.Parsetree.class_expr = - fun - { From.Parsetree.pcl_desc = pcl_desc; - From.Parsetree.pcl_loc = pcl_loc; - From.Parsetree.pcl_attributes = pcl_attributes } - -> - { - To.Parsetree.pcl_desc = - (copy_class_expr_desc pcl_desc); - To.Parsetree.pcl_loc = (copy_location pcl_loc); - To.Parsetree.pcl_attributes = - (copy_attributes pcl_attributes) - } - -and copy_class_expr_desc : - From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = - function - | From.Parsetree.Pcl_constr (x0,x1) -> - To.Parsetree.Pcl_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcl_structure x0 -> - To.Parsetree.Pcl_structure - (copy_class_structure x0) - | From.Parsetree.Pcl_fun (x0,x1,x2,x3) -> - To.Parsetree.Pcl_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_class_expr x3)) - | From.Parsetree.Pcl_apply (x0,x1) -> - To.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pcl_let (x0,x1,x2) -> - To.Parsetree.Pcl_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_class_expr x2)) - | From.Parsetree.Pcl_constraint (x0,x1) -> - To.Parsetree.Pcl_constraint - ((copy_class_expr x0), - (copy_class_type x1)) - | From.Parsetree.Pcl_extension x0 -> - To.Parsetree.Pcl_extension (copy_extension x0) - -and copy_class_structure : - From.Parsetree.class_structure -> To.Parsetree.class_structure = - fun - { From.Parsetree.pcstr_self = pcstr_self; - From.Parsetree.pcstr_fields = pcstr_fields } - -> - { - To.Parsetree.pcstr_self = - (copy_pattern pcstr_self); - To.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } - -and copy_class_field : - From.Parsetree.class_field -> To.Parsetree.class_field = - fun - { From.Parsetree.pcf_desc = pcf_desc; - From.Parsetree.pcf_loc = pcf_loc; - From.Parsetree.pcf_attributes = pcf_attributes } - -> - { - To.Parsetree.pcf_desc = - (copy_class_field_desc pcf_desc); - To.Parsetree.pcf_loc = (copy_location pcf_loc); - To.Parsetree.pcf_attributes = - (copy_attributes pcf_attributes) - } - -and copy_class_field_desc : - From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = - function - | From.Parsetree.Pcf_inherit (x0,x1,x2) -> - To.Parsetree.Pcf_inherit - ((copy_override_flag x0), - (copy_class_expr x1), - (copy_option (fun x -> noloc x) x2)) - | From.Parsetree.Pcf_val x0 -> - To.Parsetree.Pcf_val - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_method x0 -> - To.Parsetree.Pcf_method - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_private_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_constraint x0 -> - To.Parsetree.Pcf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pcf_initializer x0 -> - To.Parsetree.Pcf_initializer - (copy_expression x0) - | From.Parsetree.Pcf_attribute x0 -> - To.Parsetree.Pcf_attribute (copy_attribute x0) - | From.Parsetree.Pcf_extension x0 -> - To.Parsetree.Pcf_extension (copy_extension x0) - -and copy_class_field_kind : - From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = - function - | From.Parsetree.Cfk_virtual x0 -> - To.Parsetree.Cfk_virtual (copy_core_type x0) - | From.Parsetree.Cfk_concrete (x0,x1) -> - To.Parsetree.Cfk_concrete - ((copy_override_flag x0), - (copy_expression x1)) - -and copy_module_binding : - From.Parsetree.module_binding -> To.Parsetree.module_binding = - fun - { From.Parsetree.pmb_name = pmb_name; - From.Parsetree.pmb_expr = pmb_expr; - From.Parsetree.pmb_attributes = pmb_attributes; - From.Parsetree.pmb_loc = pmb_loc } - -> - { - To.Parsetree.pmb_name = - (copy_loc (fun x -> x) pmb_name); - To.Parsetree.pmb_expr = - (copy_module_expr pmb_expr); - To.Parsetree.pmb_attributes = - (copy_attributes pmb_attributes); - To.Parsetree.pmb_loc = (copy_location pmb_loc) - } - -and copy_module_expr : - From.Parsetree.module_expr -> To.Parsetree.module_expr = - fun - { From.Parsetree.pmod_desc = pmod_desc; - From.Parsetree.pmod_loc = pmod_loc; - From.Parsetree.pmod_attributes = pmod_attributes } - -> - { - To.Parsetree.pmod_desc = - (copy_module_expr_desc pmod_desc); - To.Parsetree.pmod_loc = (copy_location pmod_loc); - To.Parsetree.pmod_attributes = - (copy_attributes pmod_attributes) - } - -and copy_module_expr_desc : - From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = - function - | From.Parsetree.Pmod_ident x0 -> - To.Parsetree.Pmod_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmod_structure x0 -> - To.Parsetree.Pmod_structure (copy_structure x0) - | From.Parsetree.Pmod_functor (x0,x1,x2) -> - To.Parsetree.Pmod_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_expr x2)) - | From.Parsetree.Pmod_apply (x0,x1) -> - To.Parsetree.Pmod_apply - ((copy_module_expr x0), - (copy_module_expr x1)) - | From.Parsetree.Pmod_constraint (x0,x1) -> - To.Parsetree.Pmod_constraint - ((copy_module_expr x0), - (copy_module_type x1)) - | From.Parsetree.Pmod_unpack x0 -> - To.Parsetree.Pmod_unpack (copy_expression x0) - | From.Parsetree.Pmod_extension x0 -> - To.Parsetree.Pmod_extension (copy_extension x0) - -and copy_module_type : - From.Parsetree.module_type -> To.Parsetree.module_type = - fun - { From.Parsetree.pmty_desc = pmty_desc; - From.Parsetree.pmty_loc = pmty_loc; - From.Parsetree.pmty_attributes = pmty_attributes } - -> - { - To.Parsetree.pmty_desc = - (copy_module_type_desc pmty_desc); - To.Parsetree.pmty_loc = (copy_location pmty_loc); - To.Parsetree.pmty_attributes = - (copy_attributes pmty_attributes) - } - -and copy_module_type_desc : - From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = - function - | From.Parsetree.Pmty_ident x0 -> - To.Parsetree.Pmty_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmty_signature x0 -> - To.Parsetree.Pmty_signature (copy_signature x0) - | From.Parsetree.Pmty_functor (x0,x1,x2) -> - To.Parsetree.Pmty_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_type x2)) - | From.Parsetree.Pmty_with (x0,x1) -> - To.Parsetree.Pmty_with - ((copy_module_type x0), - (List.map copy_with_constraint x1)) - | From.Parsetree.Pmty_typeof x0 -> - To.Parsetree.Pmty_typeof (copy_module_expr x0) - | From.Parsetree.Pmty_extension x0 -> - To.Parsetree.Pmty_extension (copy_extension x0) - | From.Parsetree.Pmty_alias x0 -> - To.Parsetree.Pmty_alias - (copy_loc copy_longident x0) - -and copy_with_constraint : - From.Parsetree.with_constraint -> To.Parsetree.with_constraint = - function - | From.Parsetree.Pwith_type (x0,x1) -> - To.Parsetree.Pwith_type - ((copy_loc copy_longident x0), - (copy_type_declaration x1)) - | From.Parsetree.Pwith_module (x0,x1) -> - To.Parsetree.Pwith_module - ((copy_loc copy_longident x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pwith_typesubst x0 -> - To.Parsetree.Pwith_typesubst - (copy_type_declaration x0) - | From.Parsetree.Pwith_modsubst (x0,x1) -> - To.Parsetree.Pwith_modsubst - ((copy_loc (fun x -> x) x0), - (copy_loc copy_longident x1)) - -and copy_signature : - From.Parsetree.signature -> To.Parsetree.signature = - fun x -> List.map copy_signature_item x - -and copy_signature_item : - From.Parsetree.signature_item -> To.Parsetree.signature_item = - fun - { From.Parsetree.psig_desc = psig_desc; - From.Parsetree.psig_loc = psig_loc } - -> - { - To.Parsetree.psig_desc = - (copy_signature_item_desc psig_desc); - To.Parsetree.psig_loc = (copy_location psig_loc) - } - -and copy_signature_item_desc : - From.Parsetree.signature_item_desc -> - To.Parsetree.signature_item_desc - = - function - | From.Parsetree.Psig_value x0 -> - To.Parsetree.Psig_value - (copy_value_description x0) - | From.Parsetree.Psig_type (x0,x1) -> - To.Parsetree.Psig_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Psig_typext x0 -> - To.Parsetree.Psig_typext - (copy_type_extension x0) - | From.Parsetree.Psig_exception x0 -> - To.Parsetree.Psig_exception - (copy_extension_constructor x0) - | From.Parsetree.Psig_module x0 -> - To.Parsetree.Psig_module - (copy_module_declaration x0) - | From.Parsetree.Psig_recmodule x0 -> - To.Parsetree.Psig_recmodule - (List.map copy_module_declaration x0) - | From.Parsetree.Psig_modtype x0 -> - To.Parsetree.Psig_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Psig_open x0 -> - To.Parsetree.Psig_open - (copy_open_description x0) - | From.Parsetree.Psig_include x0 -> - To.Parsetree.Psig_include - (copy_include_description x0) - | From.Parsetree.Psig_class x0 -> - To.Parsetree.Psig_class - (List.map copy_class_description x0) - | From.Parsetree.Psig_class_type x0 -> - To.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Psig_attribute x0 -> - To.Parsetree.Psig_attribute (copy_attribute x0) - | From.Parsetree.Psig_extension (x0,x1) -> - To.Parsetree.Psig_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_class_type_declaration : - From.Parsetree.class_type_declaration -> - To.Parsetree.class_type_declaration - = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_description : - From.Parsetree.class_description -> To.Parsetree.class_description - = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_type : - From.Parsetree.class_type -> To.Parsetree.class_type = - fun - { From.Parsetree.pcty_desc = pcty_desc; - From.Parsetree.pcty_loc = pcty_loc; - From.Parsetree.pcty_attributes = pcty_attributes } - -> - { - To.Parsetree.pcty_desc = - (copy_class_type_desc pcty_desc); - To.Parsetree.pcty_loc = (copy_location pcty_loc); - To.Parsetree.pcty_attributes = - (copy_attributes pcty_attributes) - } - -and copy_class_type_desc : - From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = - function - | From.Parsetree.Pcty_constr (x0,x1) -> - To.Parsetree.Pcty_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcty_signature x0 -> - To.Parsetree.Pcty_signature - (copy_class_signature x0) - | From.Parsetree.Pcty_arrow (x0,x1,x2) -> - To.Parsetree.Pcty_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_class_type x2)) - | From.Parsetree.Pcty_extension x0 -> - To.Parsetree.Pcty_extension (copy_extension x0) - -and copy_class_signature : - From.Parsetree.class_signature -> To.Parsetree.class_signature = - fun - { From.Parsetree.pcsig_self = pcsig_self; - From.Parsetree.pcsig_fields = pcsig_fields } - -> - { - To.Parsetree.pcsig_self = - (copy_core_type pcsig_self); - To.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } - -and copy_class_type_field : - From.Parsetree.class_type_field -> To.Parsetree.class_type_field = - fun - { From.Parsetree.pctf_desc = pctf_desc; - From.Parsetree.pctf_loc = pctf_loc; - From.Parsetree.pctf_attributes = pctf_attributes } - -> - { - To.Parsetree.pctf_desc = - (copy_class_type_field_desc pctf_desc); - To.Parsetree.pctf_loc = (copy_location pctf_loc); - To.Parsetree.pctf_attributes = - (copy_attributes pctf_attributes) - } - -and copy_class_type_field_desc : - From.Parsetree.class_type_field_desc -> - To.Parsetree.class_type_field_desc - = - function - | From.Parsetree.Pctf_inherit x0 -> - To.Parsetree.Pctf_inherit (copy_class_type x0) - | From.Parsetree.Pctf_val x0 -> - To.Parsetree.Pctf_val - (let (x0,x1,x2,x3) = x0 in - (noloc x0, (copy_mutable_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_method x0 -> - To.Parsetree.Pctf_method - (let (x0,x1,x2,x3) = x0 in - (noloc x0, (copy_private_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_constraint x0 -> - To.Parsetree.Pctf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pctf_attribute x0 -> - To.Parsetree.Pctf_attribute (copy_attribute x0) - | From.Parsetree.Pctf_extension x0 -> - To.Parsetree.Pctf_extension (copy_extension x0) - -and copy_extension : - From.Parsetree.extension -> To.Parsetree.extension = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.class_infos -> 'g0 To.Parsetree.class_infos - = - fun f0 -> - fun - { From.Parsetree.pci_virt = pci_virt; - From.Parsetree.pci_params = pci_params; - From.Parsetree.pci_name = pci_name; - From.Parsetree.pci_expr = pci_expr; - From.Parsetree.pci_loc = pci_loc; - From.Parsetree.pci_attributes = pci_attributes } - -> - { - To.Parsetree.pci_virt = - (copy_virtual_flag pci_virt); - To.Parsetree.pci_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) pci_params); - To.Parsetree.pci_name = - (copy_loc (fun x -> x) pci_name); - To.Parsetree.pci_expr = (f0 pci_expr); - To.Parsetree.pci_loc = (copy_location pci_loc); - To.Parsetree.pci_attributes = - (copy_attributes pci_attributes) - } - -and copy_virtual_flag : - From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = - function - | From.Asttypes.Virtual -> To.Asttypes.Virtual - | From.Asttypes.Concrete -> To.Asttypes.Concrete - -and copy_include_description : - From.Parsetree.include_description -> - To.Parsetree.include_description - = - fun x -> - copy_include_infos copy_module_type x - -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.include_infos -> - 'g0 To.Parsetree.include_infos - = - fun f0 -> - fun - { From.Parsetree.pincl_mod = pincl_mod; - From.Parsetree.pincl_loc = pincl_loc; - From.Parsetree.pincl_attributes = pincl_attributes } - -> - { - To.Parsetree.pincl_mod = (f0 pincl_mod); - To.Parsetree.pincl_loc = (copy_location pincl_loc); - To.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } - -and copy_open_description : - From.Parsetree.open_description -> To.Parsetree.open_description = - fun - { From.Parsetree.popen_lid = popen_lid; - From.Parsetree.popen_override = popen_override; - From.Parsetree.popen_loc = popen_loc; - From.Parsetree.popen_attributes = popen_attributes } - -> - { - To.Parsetree.popen_lid = - (copy_loc copy_longident popen_lid); - To.Parsetree.popen_override = - (copy_override_flag popen_override); - To.Parsetree.popen_loc = (copy_location popen_loc); - To.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } - -and copy_override_flag : - From.Asttypes.override_flag -> To.Asttypes.override_flag = - function - | From.Asttypes.Override -> To.Asttypes.Override - | From.Asttypes.Fresh -> To.Asttypes.Fresh - -and copy_module_type_declaration : - From.Parsetree.module_type_declaration -> - To.Parsetree.module_type_declaration +let rec copy_out_type_extension : + Ast_404.Outcometree.out_type_extension -> + Ast_405.Outcometree.out_type_extension = fun - { From.Parsetree.pmtd_name = pmtd_name; - From.Parsetree.pmtd_type = pmtd_type; - From.Parsetree.pmtd_attributes = pmtd_attributes; - From.Parsetree.pmtd_loc = pmtd_loc } - -> + { Ast_404.Outcometree.otyext_name = otyext_name; + Ast_404.Outcometree.otyext_params = otyext_params; + Ast_404.Outcometree.otyext_constructors = otyext_constructors; + Ast_404.Outcometree.otyext_private = otyext_private } + -> { - To.Parsetree.pmtd_name = - (copy_loc (fun x -> x) pmtd_name); - To.Parsetree.pmtd_type = - (copy_option copy_module_type pmtd_type); - To.Parsetree.pmtd_attributes = - (copy_attributes pmtd_attributes); - To.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } - -and copy_module_declaration : - From.Parsetree.module_declaration -> - To.Parsetree.module_declaration - = - fun - { From.Parsetree.pmd_name = pmd_name; - From.Parsetree.pmd_type = pmd_type; - From.Parsetree.pmd_attributes = pmd_attributes; - From.Parsetree.pmd_loc = pmd_loc } - -> - { - To.Parsetree.pmd_name = - (copy_loc (fun x -> x) pmd_name); - To.Parsetree.pmd_type = - (copy_module_type pmd_type); - To.Parsetree.pmd_attributes = - (copy_attributes pmd_attributes); - To.Parsetree.pmd_loc = (copy_location pmd_loc) - } - -and copy_type_extension : - From.Parsetree.type_extension -> To.Parsetree.type_extension = - fun - { From.Parsetree.ptyext_path = ptyext_path; - From.Parsetree.ptyext_params = ptyext_params; - From.Parsetree.ptyext_constructors = ptyext_constructors; - From.Parsetree.ptyext_private = ptyext_private; - From.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - To.Parsetree.ptyext_path = - (copy_loc copy_longident ptyext_path); - To.Parsetree.ptyext_params = + Ast_405.Outcometree.otyext_name = otyext_name; + Ast_405.Outcometree.otyext_params = + (List.map (fun x -> x) otyext_params); + Ast_405.Outcometree.otyext_constructors = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptyext_params); - To.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor - ptyext_constructors); - To.Parsetree.ptyext_private = - (copy_private_flag ptyext_private); - To.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } - -and copy_extension_constructor : - From.Parsetree.extension_constructor -> - To.Parsetree.extension_constructor - = - fun - { From.Parsetree.pext_name = pext_name; - From.Parsetree.pext_kind = pext_kind; - From.Parsetree.pext_loc = pext_loc; - From.Parsetree.pext_attributes = pext_attributes } - -> - { - To.Parsetree.pext_name = - (copy_loc (fun x -> x) pext_name); - To.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - To.Parsetree.pext_loc = (copy_location pext_loc); - To.Parsetree.pext_attributes = - (copy_attributes pext_attributes) - } - -and copy_extension_constructor_kind : - From.Parsetree.extension_constructor_kind -> - To.Parsetree.extension_constructor_kind - = - function - | From.Parsetree.Pext_decl (x0,x1) -> - To.Parsetree.Pext_decl - ((copy_constructor_arguments x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pext_rebind x0 -> - To.Parsetree.Pext_rebind - (copy_loc copy_longident x0) - -and copy_type_declaration : - From.Parsetree.type_declaration -> To.Parsetree.type_declaration = - fun - { From.Parsetree.ptype_name = ptype_name; - From.Parsetree.ptype_params = ptype_params; - From.Parsetree.ptype_cstrs = ptype_cstrs; - From.Parsetree.ptype_kind = ptype_kind; - From.Parsetree.ptype_private = ptype_private; - From.Parsetree.ptype_manifest = ptype_manifest; - From.Parsetree.ptype_attributes = ptype_attributes; - From.Parsetree.ptype_loc = ptype_loc } - -> - { - To.Parsetree.ptype_name = - (copy_loc (fun x -> x) ptype_name); - To.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptype_params); - To.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0,x1,x2) = x in - ((copy_core_type x0), - (copy_core_type x1), - (copy_location x2))) ptype_cstrs); - To.Parsetree.ptype_kind = - (copy_type_kind ptype_kind); - To.Parsetree.ptype_private = - (copy_private_flag ptype_private); - To.Parsetree.ptype_manifest = - (copy_option copy_core_type ptype_manifest); - To.Parsetree.ptype_attributes = - (copy_attributes ptype_attributes); - To.Parsetree.ptype_loc = (copy_location ptype_loc) - } - -and copy_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = - function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - -and copy_type_kind : - From.Parsetree.type_kind -> To.Parsetree.type_kind = - function - | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract - | From.Parsetree.Ptype_variant x0 -> - To.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | From.Parsetree.Ptype_record x0 -> - To.Parsetree.Ptype_record - (List.map copy_label_declaration x0) - | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open - -and copy_constructor_declaration : - From.Parsetree.constructor_declaration -> - To.Parsetree.constructor_declaration - = - fun - { From.Parsetree.pcd_name = pcd_name; - From.Parsetree.pcd_args = pcd_args; - From.Parsetree.pcd_res = pcd_res; - From.Parsetree.pcd_loc = pcd_loc; - From.Parsetree.pcd_attributes = pcd_attributes } - -> - { - To.Parsetree.pcd_name = - (copy_loc (fun x -> x) pcd_name); - To.Parsetree.pcd_args = - (copy_constructor_arguments pcd_args); - To.Parsetree.pcd_res = - (copy_option copy_core_type pcd_res); - To.Parsetree.pcd_loc = (copy_location pcd_loc); - To.Parsetree.pcd_attributes = - (copy_attributes pcd_attributes) - } - -and copy_constructor_arguments : - From.Parsetree.constructor_arguments -> - To.Parsetree.constructor_arguments - = - function - | From.Parsetree.Pcstr_tuple x0 -> - To.Parsetree.Pcstr_tuple - (List.map copy_core_type x0) - | From.Parsetree.Pcstr_record x0 -> - To.Parsetree.Pcstr_record - (List.map copy_label_declaration x0) - -and copy_label_declaration : - From.Parsetree.label_declaration -> To.Parsetree.label_declaration - = - fun - { From.Parsetree.pld_name = pld_name; - From.Parsetree.pld_mutable = pld_mutable; - From.Parsetree.pld_type = pld_type; - From.Parsetree.pld_loc = pld_loc; - From.Parsetree.pld_attributes = pld_attributes } - -> - { - To.Parsetree.pld_name = - (copy_loc (fun x -> x) pld_name); - To.Parsetree.pld_mutable = - (copy_mutable_flag pld_mutable); - To.Parsetree.pld_type = - (copy_core_type pld_type); - To.Parsetree.pld_loc = (copy_location pld_loc); - To.Parsetree.pld_attributes = - (copy_attributes pld_attributes) - } - -and copy_mutable_flag : - From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = - function - | From.Asttypes.Immutable -> To.Asttypes.Immutable - | From.Asttypes.Mutable -> To.Asttypes.Mutable - -and copy_variance : - From.Asttypes.variance -> To.Asttypes.variance = - function - | From.Asttypes.Covariant -> To.Asttypes.Covariant - | From.Asttypes.Contravariant -> To.Asttypes.Contravariant - | From.Asttypes.Invariant -> To.Asttypes.Invariant - -and copy_value_description : - From.Parsetree.value_description -> To.Parsetree.value_description - = - fun - { From.Parsetree.pval_name = pval_name; - From.Parsetree.pval_type = pval_type; - From.Parsetree.pval_prim = pval_prim; - From.Parsetree.pval_attributes = pval_attributes; - From.Parsetree.pval_loc = pval_loc } - -> - { - To.Parsetree.pval_name = - (copy_loc (fun x -> x) pval_name); - To.Parsetree.pval_type = - (copy_core_type pval_type); - To.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - To.Parsetree.pval_attributes = - (copy_attributes pval_attributes); - To.Parsetree.pval_loc = (copy_location pval_loc) - } - -and copy_arg_label : - From.Asttypes.arg_label -> To.Asttypes.arg_label = - function - | From.Asttypes.Nolabel -> To.Asttypes.Nolabel - | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 - | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 - -and copy_closed_flag : - From.Asttypes.closed_flag -> To.Asttypes.closed_flag = - function - | From.Asttypes.Closed -> To.Asttypes.Closed - | From.Asttypes.Open -> To.Asttypes.Open - -and copy_label : - From.Asttypes.label -> To.Asttypes.label = fun x -> x - -and copy_rec_flag : - From.Asttypes.rec_flag -> To.Asttypes.rec_flag = - function - | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive - | From.Asttypes.Recursive -> To.Asttypes.Recursive - -and copy_constant : - From.Parsetree.constant -> To.Parsetree.constant = - function - | From.Parsetree.Pconst_integer (x0,x1) -> - To.Parsetree.Pconst_integer (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 - | From.Parsetree.Pconst_string (x0,x1) -> - To.Parsetree.Pconst_string (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_float (x0,x1) -> - To.Parsetree.Pconst_float (x0, (copy_option (fun x -> x) x1)) - -and copy_option : 'f0 'g0 . ('f0 -> 'g0) -> 'f0 option -> 'g0 option = - fun f0 -> function | None -> None | Some x0 -> Some (f0 x0) - -and copy_longident : From.Longident.t -> To.Longident.t = - function - | From.Longident.Lident x0 -> To.Longident.Lident x0 - | From.Longident.Ldot (x0,x1) -> - To.Longident.Ldot ((copy_longident x0), x1) - | From.Longident.Lapply (x0,x1) -> - To.Longident.Lapply - ((copy_longident x0), (copy_longident x1)) - -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc - = - fun f0 -> - fun { From.Asttypes.txt = txt; From.Asttypes.loc = loc } -> - { - To.Asttypes.txt = (f0 txt); - To.Asttypes.loc = (copy_location loc) - } - -and copy_location : From.Location.t -> To.Location.t = - fun - { From.Location.loc_start = loc_start; - From.Location.loc_end = loc_end; - From.Location.loc_ghost = loc_ghost } - -> - { - To.Location.loc_start = (copy_Lexing_position loc_start); - To.Location.loc_end = (copy_Lexing_position loc_end); - To.Location.loc_ghost = (copy_bool loc_ghost) - } - -and copy_bool : bool -> bool = function | false -> false | true -> true - -and copy_Lexing_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum + (fun x -> + let (x0, x1, x2) = x in + (x0, (List.map copy_out_type x1), + (Option.map copy_out_type x2))) otyext_constructors); + Ast_405.Outcometree.otyext_private = (copy_private_flag otyext_private) } - -let rec copy_out_phrase : - From.Outcometree.out_phrase -> To.Outcometree.out_phrase = +and copy_out_phrase : + Ast_404.Outcometree.out_phrase -> Ast_405.Outcometree.out_phrase = function - | From.Outcometree.Ophr_eval (x0,x1) -> - To.Outcometree.Ophr_eval - ((copy_out_value x0), - (copy_out_type x1)) - | From.Outcometree.Ophr_signature x0 -> - To.Outcometree.Ophr_signature + | Ast_404.Outcometree.Ophr_eval (x0, x1) -> + Ast_405.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1)) + | Ast_404.Outcometree.Ophr_signature x0 -> + Ast_405.Outcometree.Ophr_signature (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_sig_item x0), - (copy_option copy_out_value x1))) x0) - | From.Outcometree.Ophr_exception x0 -> - To.Outcometree.Ophr_exception - (let (x0,x1) = x0 in - ((copy_exn x0), (copy_out_value x1))) - -and copy_exn : exn -> exn = fun x -> x - + (fun x -> + let (x0, x1) = x in + ((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0) + | Ast_404.Outcometree.Ophr_exception x0 -> + Ast_405.Outcometree.Ophr_exception + (let (x0, x1) = x0 in (x0, (copy_out_value x1))) and copy_out_sig_item : - From.Outcometree.out_sig_item -> To.Outcometree.out_sig_item = + Ast_404.Outcometree.out_sig_item -> Ast_405.Outcometree.out_sig_item = function - | From.Outcometree.Osig_class (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class - ((copy_bool x0), x1, + | Ast_404.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> + Ast_405.Outcometree.Osig_class + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_class_type (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class_type - ((copy_bool x0), x1, + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_404.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> + Ast_405.Outcometree.Osig_class_type + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_typext (x0,x1) -> - To.Outcometree.Osig_typext - ((copy_out_extension_constructor x0), - (copy_out_ext_status x1)) - | From.Outcometree.Osig_modtype (x0,x1) -> - To.Outcometree.Osig_modtype - (x0, (copy_out_module_type x1)) - | From.Outcometree.Osig_module (x0,x1,x2) -> - To.Outcometree.Osig_module - (x0, (copy_out_module_type x1), - (copy_out_rec_status x2)) - | From.Outcometree.Osig_type (x0,x1) -> - To.Outcometree.Osig_type - ((copy_out_type_decl x0), - (copy_out_rec_status x1)) - | From.Outcometree.Osig_value x0 -> - To.Outcometree.Osig_value - (copy_out_val_decl x0) - | From.Outcometree.Osig_ellipsis -> To.Outcometree.Osig_ellipsis - + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_404.Outcometree.Osig_typext (x0, x1) -> + Ast_405.Outcometree.Osig_typext + ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) + | Ast_404.Outcometree.Osig_modtype (x0, x1) -> + Ast_405.Outcometree.Osig_modtype (x0, (copy_out_module_type x1)) + | Ast_404.Outcometree.Osig_module (x0, x1, x2) -> + Ast_405.Outcometree.Osig_module + (x0, (copy_out_module_type x1), (copy_out_rec_status x2)) + | Ast_404.Outcometree.Osig_type (x0, x1) -> + Ast_405.Outcometree.Osig_type + ((copy_out_type_decl x0), (copy_out_rec_status x1)) + | Ast_404.Outcometree.Osig_value x0 -> + Ast_405.Outcometree.Osig_value (copy_out_val_decl x0) + | Ast_404.Outcometree.Osig_ellipsis -> Ast_405.Outcometree.Osig_ellipsis and copy_out_val_decl : - From.Outcometree.out_val_decl -> To.Outcometree.out_val_decl = + Ast_404.Outcometree.out_val_decl -> Ast_405.Outcometree.out_val_decl = fun - { From.Outcometree.oval_name = oval_name; - From.Outcometree.oval_type = oval_type; - From.Outcometree.oval_prims = oval_prims; - From.Outcometree.oval_attributes = oval_attributes } - -> + { Ast_404.Outcometree.oval_name = oval_name; + Ast_404.Outcometree.oval_type = oval_type; + Ast_404.Outcometree.oval_prims = oval_prims; + Ast_404.Outcometree.oval_attributes = oval_attributes } + -> { - To.Outcometree.oval_name = oval_name; - To.Outcometree.oval_type = - (copy_out_type oval_type); - To.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); - To.Outcometree.oval_attributes = + Ast_405.Outcometree.oval_name = oval_name; + Ast_405.Outcometree.oval_type = (copy_out_type oval_type); + Ast_405.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); + Ast_405.Outcometree.oval_attributes = (List.map copy_out_attribute oval_attributes) } - and copy_out_type_decl : - From.Outcometree.out_type_decl -> To.Outcometree.out_type_decl = + Ast_404.Outcometree.out_type_decl -> Ast_405.Outcometree.out_type_decl = fun - { From.Outcometree.otype_name = otype_name; - From.Outcometree.otype_params = otype_params; - From.Outcometree.otype_type = otype_type; - From.Outcometree.otype_private = otype_private; - From.Outcometree.otype_immediate = otype_immediate; - From.Outcometree.otype_unboxed = otype_unboxed; - From.Outcometree.otype_cstrs = otype_cstrs } - -> + { Ast_404.Outcometree.otype_name = otype_name; + Ast_404.Outcometree.otype_params = otype_params; + Ast_404.Outcometree.otype_type = otype_type; + Ast_404.Outcometree.otype_private = otype_private; + Ast_404.Outcometree.otype_immediate = otype_immediate; + Ast_404.Outcometree.otype_unboxed = otype_unboxed; + Ast_404.Outcometree.otype_cstrs = otype_cstrs } + -> { - To.Outcometree.otype_name = otype_name; - To.Outcometree.otype_params = + Ast_405.Outcometree.otype_name = otype_name; + Ast_405.Outcometree.otype_params = (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) otype_params); - To.Outcometree.otype_type = - (copy_out_type otype_type); - To.Outcometree.otype_private = - (copy_From_Asttypes_private_flag otype_private); - To.Outcometree.otype_immediate = (copy_bool otype_immediate); - To.Outcometree.otype_unboxed = (copy_bool otype_unboxed); - To.Outcometree.otype_cstrs = + Ast_405.Outcometree.otype_type = (copy_out_type otype_type); + Ast_405.Outcometree.otype_private = (copy_private_flag otype_private); + Ast_405.Outcometree.otype_immediate = otype_immediate; + Ast_405.Outcometree.otype_unboxed = otype_unboxed; + Ast_405.Outcometree.otype_cstrs = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_type x0), - (copy_out_type x1))) otype_cstrs) + (fun x -> + let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1))) + otype_cstrs) } - and copy_out_module_type : - From.Outcometree.out_module_type -> To.Outcometree.out_module_type + Ast_404.Outcometree.out_module_type -> Ast_405.Outcometree.out_module_type = function - | From.Outcometree.Omty_abstract -> To.Outcometree.Omty_abstract - | From.Outcometree.Omty_functor (x0,x1,x2) -> - To.Outcometree.Omty_functor - (x0, (copy_option copy_out_module_type x1), - (copy_out_module_type x2)) - | From.Outcometree.Omty_ident x0 -> - To.Outcometree.Omty_ident (copy_out_ident x0) - | From.Outcometree.Omty_signature x0 -> - To.Outcometree.Omty_signature - (List.map copy_out_sig_item x0) - | From.Outcometree.Omty_alias x0 -> - To.Outcometree.Omty_alias (copy_out_ident x0) - + | Ast_404.Outcometree.Omty_abstract -> Ast_405.Outcometree.Omty_abstract + | Ast_404.Outcometree.Omty_functor (x0, x1, x2) -> + Ast_405.Outcometree.Omty_functor + (x0, (Option.map copy_out_module_type x1), (copy_out_module_type x2)) + | Ast_404.Outcometree.Omty_ident x0 -> + Ast_405.Outcometree.Omty_ident (copy_out_ident x0) + | Ast_404.Outcometree.Omty_signature x0 -> + Ast_405.Outcometree.Omty_signature (List.map copy_out_sig_item x0) + | Ast_404.Outcometree.Omty_alias x0 -> + Ast_405.Outcometree.Omty_alias (copy_out_ident x0) and copy_out_ext_status : - From.Outcometree.out_ext_status -> To.Outcometree.out_ext_status = + Ast_404.Outcometree.out_ext_status -> Ast_405.Outcometree.out_ext_status = function - | From.Outcometree.Oext_first -> To.Outcometree.Oext_first - | From.Outcometree.Oext_next -> To.Outcometree.Oext_next - | From.Outcometree.Oext_exception -> To.Outcometree.Oext_exception - + | Ast_404.Outcometree.Oext_first -> Ast_405.Outcometree.Oext_first + | Ast_404.Outcometree.Oext_next -> Ast_405.Outcometree.Oext_next + | Ast_404.Outcometree.Oext_exception -> Ast_405.Outcometree.Oext_exception and copy_out_extension_constructor : - From.Outcometree.out_extension_constructor -> - To.Outcometree.out_extension_constructor + Ast_404.Outcometree.out_extension_constructor -> + Ast_405.Outcometree.out_extension_constructor = fun - { From.Outcometree.oext_name = oext_name; - From.Outcometree.oext_type_name = oext_type_name; - From.Outcometree.oext_type_params = oext_type_params; - From.Outcometree.oext_args = oext_args; - From.Outcometree.oext_ret_type = oext_ret_type; - From.Outcometree.oext_private = oext_private } - -> + { Ast_404.Outcometree.oext_name = oext_name; + Ast_404.Outcometree.oext_type_name = oext_type_name; + Ast_404.Outcometree.oext_type_params = oext_type_params; + Ast_404.Outcometree.oext_args = oext_args; + Ast_404.Outcometree.oext_ret_type = oext_ret_type; + Ast_404.Outcometree.oext_private = oext_private } + -> { - To.Outcometree.oext_name = oext_name; - To.Outcometree.oext_type_name = oext_type_name; - To.Outcometree.oext_type_params = - (List.map (fun x -> x) oext_type_params); - To.Outcometree.oext_args = - (List.map copy_out_type oext_args); - To.Outcometree.oext_ret_type = - (copy_option copy_out_type oext_ret_type); - To.Outcometree.oext_private = - (copy_From_Asttypes_private_flag oext_private) + Ast_405.Outcometree.oext_name = oext_name; + Ast_405.Outcometree.oext_type_name = oext_type_name; + Ast_405.Outcometree.oext_type_params = + (List.map (fun x -> x) oext_type_params); + Ast_405.Outcometree.oext_args = (List.map copy_out_type oext_args); + Ast_405.Outcometree.oext_ret_type = + (Option.map copy_out_type oext_ret_type); + Ast_405.Outcometree.oext_private = (copy_private_flag oext_private) } - -and copy_From_Asttypes_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = +and copy_private_flag : + Ast_404.Asttypes.private_flag -> Ast_405.Asttypes.private_flag = function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - + | Ast_404.Asttypes.Private -> Ast_405.Asttypes.Private + | Ast_404.Asttypes.Public -> Ast_405.Asttypes.Public and copy_out_rec_status : - From.Outcometree.out_rec_status -> To.Outcometree.out_rec_status = + Ast_404.Outcometree.out_rec_status -> Ast_405.Outcometree.out_rec_status = function - | From.Outcometree.Orec_not -> To.Outcometree.Orec_not - | From.Outcometree.Orec_first -> To.Outcometree.Orec_first - | From.Outcometree.Orec_next -> To.Outcometree.Orec_next - + | Ast_404.Outcometree.Orec_not -> Ast_405.Outcometree.Orec_not + | Ast_404.Outcometree.Orec_first -> Ast_405.Outcometree.Orec_first + | Ast_404.Outcometree.Orec_next -> Ast_405.Outcometree.Orec_next and copy_out_class_type : - From.Outcometree.out_class_type -> To.Outcometree.out_class_type = - function - | From.Outcometree.Octy_constr (x0,x1) -> - To.Outcometree.Octy_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Octy_arrow (x0,x1,x2) -> - To.Outcometree.Octy_arrow - (x0, (copy_out_type x1), - (copy_out_class_type x2)) - | From.Outcometree.Octy_signature (x0,x1) -> - To.Outcometree.Octy_signature - ((copy_option copy_out_type x0), + Ast_404.Outcometree.out_class_type -> Ast_405.Outcometree.out_class_type = + function + | Ast_404.Outcometree.Octy_constr (x0, x1) -> + Ast_405.Outcometree.Octy_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_404.Outcometree.Octy_arrow (x0, x1, x2) -> + Ast_405.Outcometree.Octy_arrow + (x0, (copy_out_type x1), (copy_out_class_type x2)) + | Ast_404.Outcometree.Octy_signature (x0, x1) -> + Ast_405.Outcometree.Octy_signature + ((Option.map copy_out_type x0), (List.map copy_out_class_sig_item x1)) - and copy_out_class_sig_item : - From.Outcometree.out_class_sig_item -> - To.Outcometree.out_class_sig_item + Ast_404.Outcometree.out_class_sig_item -> + Ast_405.Outcometree.out_class_sig_item = function - | From.Outcometree.Ocsg_constraint (x0,x1) -> - To.Outcometree.Ocsg_constraint - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Ocsg_method (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_method - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - | From.Outcometree.Ocsg_value (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_value - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - + | Ast_404.Outcometree.Ocsg_constraint (x0, x1) -> + Ast_405.Outcometree.Ocsg_constraint + ((copy_out_type x0), (copy_out_type x1)) + | Ast_404.Outcometree.Ocsg_method (x0, x1, x2, x3) -> + Ast_405.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3)) + | Ast_404.Outcometree.Ocsg_value (x0, x1, x2, x3) -> + Ast_405.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3)) and copy_out_type : - From.Outcometree.out_type -> To.Outcometree.out_type = - function - | From.Outcometree.Otyp_abstract -> To.Outcometree.Otyp_abstract - | From.Outcometree.Otyp_open -> To.Outcometree.Otyp_open - | From.Outcometree.Otyp_alias (x0,x1) -> - To.Outcometree.Otyp_alias - ((copy_out_type x0), x1) - | From.Outcometree.Otyp_arrow (x0,x1,x2) -> - To.Outcometree.Otyp_arrow - (x0, (copy_out_type x1), - (copy_out_type x2)) - | From.Outcometree.Otyp_class (x0,x1,x2) -> - To.Outcometree.Otyp_class - ((copy_bool x0), (copy_out_ident x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_constr (x0,x1) -> - To.Outcometree.Otyp_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Otyp_manifest (x0,x1) -> - To.Outcometree.Otyp_manifest - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Otyp_object (x0,x1) -> - To.Outcometree.Otyp_object - ((List.map - (fun x -> - let (x0,x1) = x in - (x0, (copy_out_type x1))) x0), - (copy_option copy_bool x1)) - | From.Outcometree.Otyp_record x0 -> - To.Outcometree.Otyp_record + Ast_404.Outcometree.out_type -> Ast_405.Outcometree.out_type = + function + | Ast_404.Outcometree.Otyp_abstract -> Ast_405.Outcometree.Otyp_abstract + | Ast_404.Outcometree.Otyp_open -> Ast_405.Outcometree.Otyp_open + | Ast_404.Outcometree.Otyp_alias (x0, x1) -> + Ast_405.Outcometree.Otyp_alias ((copy_out_type x0), x1) + | Ast_404.Outcometree.Otyp_arrow (x0, x1, x2) -> + Ast_405.Outcometree.Otyp_arrow + (x0, (copy_out_type x1), (copy_out_type x2)) + | Ast_404.Outcometree.Otyp_class (x0, x1, x2) -> + Ast_405.Outcometree.Otyp_class + (x0, (copy_out_ident x1), (List.map copy_out_type x2)) + | Ast_404.Outcometree.Otyp_constr (x0, x1) -> + Ast_405.Outcometree.Otyp_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_404.Outcometree.Otyp_manifest (x0, x1) -> + Ast_405.Outcometree.Otyp_manifest + ((copy_out_type x0), (copy_out_type x1)) + | Ast_404.Outcometree.Otyp_object (x0, x1) -> + Ast_405.Outcometree.Otyp_object + ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0), + (Option.map (fun x -> x) x1)) + | Ast_404.Outcometree.Otyp_record x0 -> + Ast_405.Outcometree.Otyp_record (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), (copy_out_type x2))) - x0) - | From.Outcometree.Otyp_stuff x0 -> To.Outcometree.Otyp_stuff x0 - | From.Outcometree.Otyp_sum x0 -> - To.Outcometree.Otyp_sum + (fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0) + | Ast_404.Outcometree.Otyp_stuff x0 -> Ast_405.Outcometree.Otyp_stuff x0 + | Ast_404.Outcometree.Otyp_sum x0 -> + Ast_405.Outcometree.Otyp_sum (List.map - (fun x -> - let (x0,x1,x2) = x in + (fun x -> + let (x0, x1, x2) = x in (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) x0) - | From.Outcometree.Otyp_tuple x0 -> - To.Outcometree.Otyp_tuple - (List.map copy_out_type x0) - | From.Outcometree.Otyp_var (x0,x1) -> - To.Outcometree.Otyp_var ((copy_bool x0), x1) - | From.Outcometree.Otyp_variant (x0,x1,x2,x3) -> - To.Outcometree.Otyp_variant - ((copy_bool x0), (copy_out_variant x1), - (copy_bool x2), - (copy_option (fun x -> List.map (fun x -> x) x) x3)) - | From.Outcometree.Otyp_poly (x0,x1) -> - To.Outcometree.Otyp_poly - ((List.map (fun x -> x) x0), (copy_out_type x1)) - | From.Outcometree.Otyp_module (x0,x1,x2) -> - To.Outcometree.Otyp_module - (x0, (List.map (fun x -> x) x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_attribute (x0,x1) -> - To.Outcometree.Otyp_attribute - ((copy_out_type x0), - (copy_out_attribute x1)) - + (Option.map copy_out_type x2))) x0) + | Ast_404.Outcometree.Otyp_tuple x0 -> + Ast_405.Outcometree.Otyp_tuple (List.map copy_out_type x0) + | Ast_404.Outcometree.Otyp_var (x0, x1) -> + Ast_405.Outcometree.Otyp_var (x0, x1) + | Ast_404.Outcometree.Otyp_variant (x0, x1, x2, x3) -> + Ast_405.Outcometree.Otyp_variant + (x0, (copy_out_variant x1), x2, + (Option.map (fun x -> List.map (fun x -> x) x) x3)) + | Ast_404.Outcometree.Otyp_poly (x0, x1) -> + Ast_405.Outcometree.Otyp_poly + ((List.map (fun x -> x) x0), (copy_out_type x1)) + | Ast_404.Outcometree.Otyp_module (x0, x1, x2) -> + Ast_405.Outcometree.Otyp_module + (x0, (List.map (fun x -> x) x1), (List.map copy_out_type x2)) + | Ast_404.Outcometree.Otyp_attribute (x0, x1) -> + Ast_405.Outcometree.Otyp_attribute + ((copy_out_type x0), (copy_out_attribute x1)) and copy_out_attribute : - From.Outcometree.out_attribute -> To.Outcometree.out_attribute = - fun { From.Outcometree.oattr_name = oattr_name } -> - { To.Outcometree.oattr_name = oattr_name } - + Ast_404.Outcometree.out_attribute -> Ast_405.Outcometree.out_attribute = + fun { Ast_404.Outcometree.oattr_name = oattr_name } -> + { Ast_405.Outcometree.oattr_name = oattr_name } and copy_out_variant : - From.Outcometree.out_variant -> To.Outcometree.out_variant = + Ast_404.Outcometree.out_variant -> Ast_405.Outcometree.out_variant = function - | From.Outcometree.Ovar_fields x0 -> - To.Outcometree.Ovar_fields + | Ast_404.Outcometree.Ovar_fields x0 -> + Ast_405.Outcometree.Ovar_fields (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), - (List.map copy_out_type x2))) x0) - | From.Outcometree.Ovar_name (x0,x1) -> + (fun x -> + let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2))) + x0) + | Ast_404.Outcometree.Ovar_name (x0, x1) -> To.Outcometree.Ovar_typ (To.Outcometree.Otyp_constr ((copy_out_ident x0), (List.map copy_out_type x1))) - and copy_out_value : - From.Outcometree.out_value -> To.Outcometree.out_value = - function - | From.Outcometree.Oval_array x0 -> - To.Outcometree.Oval_array - (List.map copy_out_value x0) - | From.Outcometree.Oval_char x0 -> To.Outcometree.Oval_char x0 - | From.Outcometree.Oval_constr (x0,x1) -> - To.Outcometree.Oval_constr - ((copy_out_ident x0), - (List.map copy_out_value x1)) - | From.Outcometree.Oval_ellipsis -> To.Outcometree.Oval_ellipsis - | From.Outcometree.Oval_float x0 -> - To.Outcometree.Oval_float (copy_float x0) - | From.Outcometree.Oval_int x0 -> To.Outcometree.Oval_int x0 - | From.Outcometree.Oval_int32 x0 -> To.Outcometree.Oval_int32 x0 - | From.Outcometree.Oval_int64 x0 -> To.Outcometree.Oval_int64 x0 - | From.Outcometree.Oval_nativeint x0 -> - To.Outcometree.Oval_nativeint x0 - | From.Outcometree.Oval_list x0 -> - To.Outcometree.Oval_list - (List.map copy_out_value x0) - | From.Outcometree.Oval_printer x0 -> - To.Outcometree.Oval_printer x0 - | From.Outcometree.Oval_record x0 -> - To.Outcometree.Oval_record + Ast_404.Outcometree.out_value -> Ast_405.Outcometree.out_value = + function + | Ast_404.Outcometree.Oval_array x0 -> + Ast_405.Outcometree.Oval_array (List.map copy_out_value x0) + | Ast_404.Outcometree.Oval_char x0 -> Ast_405.Outcometree.Oval_char x0 + | Ast_404.Outcometree.Oval_constr (x0, x1) -> + Ast_405.Outcometree.Oval_constr + ((copy_out_ident x0), (List.map copy_out_value x1)) + | Ast_404.Outcometree.Oval_ellipsis -> Ast_405.Outcometree.Oval_ellipsis + | Ast_404.Outcometree.Oval_float x0 -> Ast_405.Outcometree.Oval_float x0 + | Ast_404.Outcometree.Oval_int x0 -> Ast_405.Outcometree.Oval_int x0 + | Ast_404.Outcometree.Oval_int32 x0 -> Ast_405.Outcometree.Oval_int32 x0 + | Ast_404.Outcometree.Oval_int64 x0 -> Ast_405.Outcometree.Oval_int64 x0 + | Ast_404.Outcometree.Oval_nativeint x0 -> + Ast_405.Outcometree.Oval_nativeint x0 + | Ast_404.Outcometree.Oval_list x0 -> + Ast_405.Outcometree.Oval_list (List.map copy_out_value x0) + | Ast_404.Outcometree.Oval_printer x0 -> + Ast_405.Outcometree.Oval_printer x0 + | Ast_404.Outcometree.Oval_record x0 -> + Ast_405.Outcometree.Oval_record (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_ident x0), - (copy_out_value x1))) x0) - | From.Outcometree.Oval_string x0 -> To.Outcometree.Oval_string x0 - | From.Outcometree.Oval_stuff x0 -> To.Outcometree.Oval_stuff x0 - | From.Outcometree.Oval_tuple x0 -> - To.Outcometree.Oval_tuple - (List.map copy_out_value x0) - | From.Outcometree.Oval_variant (x0,x1) -> - To.Outcometree.Oval_variant - (x0, (copy_option copy_out_value x1)) - -and copy_float : float -> float = fun x -> x - + (fun x -> + let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1))) + x0) + | Ast_404.Outcometree.Oval_string x0 -> Ast_405.Outcometree.Oval_string x0 + | Ast_404.Outcometree.Oval_stuff x0 -> Ast_405.Outcometree.Oval_stuff x0 + | Ast_404.Outcometree.Oval_tuple x0 -> + Ast_405.Outcometree.Oval_tuple (List.map copy_out_value x0) + | Ast_404.Outcometree.Oval_variant (x0, x1) -> + Ast_405.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1)) and copy_out_ident : - From.Outcometree.out_ident -> To.Outcometree.out_ident = - function - | From.Outcometree.Oide_apply (x0,x1) -> - To.Outcometree.Oide_apply - ((copy_out_ident x0), - (copy_out_ident x1)) - | From.Outcometree.Oide_dot (x0,x1) -> - To.Outcometree.Oide_dot - ((copy_out_ident x0), x1) - | From.Outcometree.Oide_ident x0 -> To.Outcometree.Oide_ident x0 - -let rec copy_toplevel_phrase : - From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = - function - | From.Parsetree.Ptop_def x0 -> - To.Parsetree.Ptop_def (copy_structure x0) - | From.Parsetree.Ptop_dir (x0,x1) -> - To.Parsetree.Ptop_dir - (x0, (copy_directive_argument x1)) - -and copy_directive_argument : - From.Parsetree.directive_argument -> To.Parsetree.directive_argument = - function - | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none - | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 - | From.Parsetree.Pdir_int (x0,x1) -> - To.Parsetree.Pdir_int (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pdir_ident x0 -> - To.Parsetree.Pdir_ident (copy_longident x0) - | From.Parsetree.Pdir_bool x0 -> - To.Parsetree.Pdir_bool (copy_bool x0) - -let copy_out_type_extension : - From.Outcometree.out_type_extension -> To.Outcometree.out_type_extension = - fun - { From.Outcometree.otyext_name = otyext_name; - From.Outcometree.otyext_params = otyext_params; - From.Outcometree.otyext_constructors = otyext_constructors; - From.Outcometree.otyext_private = otyext_private } - -> - { - To.Outcometree.otyext_name = otyext_name; - To.Outcometree.otyext_params = - (List.map (fun x -> x) otyext_params); - To.Outcometree.otyext_constructors = - (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) - otyext_constructors); - To.Outcometree.otyext_private = - (copy_private_flag otyext_private) - } - -let copy_cases x = List.map copy_case x -let copy_pat = copy_pattern -let copy_expr = copy_expression -let copy_typ = copy_core_type + Ast_404.Outcometree.out_ident -> Ast_405.Outcometree.out_ident = + function + | Ast_404.Outcometree.Oide_apply (x0, x1) -> + Ast_405.Outcometree.Oide_apply + ((copy_out_ident x0), (copy_out_ident x1)) + | Ast_404.Outcometree.Oide_dot (x0, x1) -> + Ast_405.Outcometree.Oide_dot ((copy_out_ident x0), x1) + | Ast_404.Outcometree.Oide_ident x0 -> Ast_405.Outcometree.Oide_ident x0 diff --git a/src/vendored-omp/src/migrate_parsetree_405_404.ml b/src/vendored-omp/src/migrate_parsetree_405_404.ml index 82cb5cd5d..f73046403 100644 --- a/src/vendored-omp/src/migrate_parsetree_405_404.ml +++ b/src/vendored-omp/src/migrate_parsetree_405_404.ml @@ -15,116 +15,3 @@ include Migrate_parsetree_405_404_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - (*$*) - } as mapper) -> - let module R = Migrate_parsetree_404_405_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_405_404_migrate.ml b/src/vendored-omp/src/migrate_parsetree_405_404_migrate.ml index e34ac74c5..5861c0ed6 100644 --- a/src/vendored-omp/src/migrate_parsetree_405_404_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_405_404_migrate.ml @@ -1,1716 +1,302 @@ -(**************************************************************************) -(* *) -(* OCaml Migrate Parsetree *) -(* *) -(* Frédéric Bour *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2017 Institut National de Recherche en Informatique et *) -(* en Automatique (INRIA). *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - +open Stdlib0 module From = Ast_405 module To = Ast_404 - -let rec copy_expression : - From.Parsetree.expression -> To.Parsetree.expression = - fun - { From.Parsetree.pexp_desc = pexp_desc; - From.Parsetree.pexp_loc = pexp_loc; - From.Parsetree.pexp_attributes = pexp_attributes } - -> - { - To.Parsetree.pexp_desc = - (copy_expression_desc pexp_desc); - To.Parsetree.pexp_loc = (copy_location pexp_loc); - To.Parsetree.pexp_attributes = - (copy_attributes pexp_attributes) - } - -and copy_expression_desc : - From.Parsetree.expression_desc -> To.Parsetree.expression_desc = - function - | From.Parsetree.Pexp_ident x0 -> - To.Parsetree.Pexp_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_constant x0 -> - To.Parsetree.Pexp_constant (copy_constant x0) - | From.Parsetree.Pexp_let (x0,x1,x2) -> - To.Parsetree.Pexp_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_expression x2)) - | From.Parsetree.Pexp_function x0 -> - To.Parsetree.Pexp_function - (List.map copy_case x0) - | From.Parsetree.Pexp_fun (x0,x1,x2,x3) -> - To.Parsetree.Pexp_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_expression x3)) - | From.Parsetree.Pexp_apply (x0,x1) -> - To.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pexp_match (x0,x1) -> - To.Parsetree.Pexp_match - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_try (x0,x1) -> - To.Parsetree.Pexp_try - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_tuple x0 -> - To.Parsetree.Pexp_tuple - (List.map copy_expression x0) - | From.Parsetree.Pexp_construct (x0,x1) -> - To.Parsetree.Pexp_construct - ((copy_loc copy_longident x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_variant (x0,x1) -> - To.Parsetree.Pexp_variant - ((copy_label x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_record (x0,x1) -> - To.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_expression x1))) x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_field (x0,x1) -> - To.Parsetree.Pexp_field - ((copy_expression x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pexp_setfield (x0,x1,x2) -> - To.Parsetree.Pexp_setfield - ((copy_expression x0), - (copy_loc copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_array x0 -> - To.Parsetree.Pexp_array - (List.map copy_expression x0) - | From.Parsetree.Pexp_ifthenelse (x0,x1,x2) -> - To.Parsetree.Pexp_ifthenelse - ((copy_expression x0), - (copy_expression x1), - (copy_option copy_expression x2)) - | From.Parsetree.Pexp_sequence (x0,x1) -> - To.Parsetree.Pexp_sequence - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_while (x0,x1) -> - To.Parsetree.Pexp_while - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_for (x0,x1,x2,x3,x4) -> - To.Parsetree.Pexp_for - ((copy_pattern x0), - (copy_expression x1), - (copy_expression x2), - (copy_direction_flag x3), - (copy_expression x4)) - | From.Parsetree.Pexp_constraint (x0,x1) -> - To.Parsetree.Pexp_constraint - ((copy_expression x0), - (copy_core_type x1)) - | From.Parsetree.Pexp_coerce (x0,x1,x2) -> - To.Parsetree.Pexp_coerce - ((copy_expression x0), - (copy_option copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Pexp_send (x0,x1) -> - To.Parsetree.Pexp_send - ((copy_expression x0), x1.From.Asttypes.txt) - | From.Parsetree.Pexp_new x0 -> - To.Parsetree.Pexp_new - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_setinstvar (x0,x1) -> - To.Parsetree.Pexp_setinstvar - ((copy_loc (fun x -> x) x0), - (copy_expression x1)) - | From.Parsetree.Pexp_override x0 -> - To.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_expression x1))) x0) - | From.Parsetree.Pexp_letmodule (x0,x1,x2) -> - To.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> x) x0), - (copy_module_expr x1), - (copy_expression x2)) - | From.Parsetree.Pexp_letexception (x0,x1) -> - To.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), - (copy_expression x1)) - | From.Parsetree.Pexp_assert x0 -> - To.Parsetree.Pexp_assert (copy_expression x0) - | From.Parsetree.Pexp_lazy x0 -> - To.Parsetree.Pexp_lazy (copy_expression x0) - | From.Parsetree.Pexp_poly (x0,x1) -> - To.Parsetree.Pexp_poly - ((copy_expression x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pexp_object x0 -> - To.Parsetree.Pexp_object - (copy_class_structure x0) - | From.Parsetree.Pexp_newtype (x0,x1) -> - To.Parsetree.Pexp_newtype - (x0.From.Asttypes.txt, (copy_expression x1)) - | From.Parsetree.Pexp_pack x0 -> - To.Parsetree.Pexp_pack (copy_module_expr x0) - | From.Parsetree.Pexp_open (x0,x1,x2) -> - To.Parsetree.Pexp_open - ((copy_override_flag x0), - (copy_loc copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_extension x0 -> - To.Parsetree.Pexp_extension (copy_extension x0) - | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable - -and copy_direction_flag : - From.Asttypes.direction_flag -> To.Asttypes.direction_flag = - function - | From.Asttypes.Upto -> To.Asttypes.Upto - | From.Asttypes.Downto -> To.Asttypes.Downto - -and copy_case : - From.Parsetree.case -> To.Parsetree.case = - fun - { From.Parsetree.pc_lhs = pc_lhs; - From.Parsetree.pc_guard = pc_guard; - From.Parsetree.pc_rhs = pc_rhs } - -> - { - To.Parsetree.pc_lhs = (copy_pattern pc_lhs); - To.Parsetree.pc_guard = - (copy_option copy_expression pc_guard); - To.Parsetree.pc_rhs = (copy_expression pc_rhs) - } - -and copy_value_binding : - From.Parsetree.value_binding -> To.Parsetree.value_binding = - fun - { From.Parsetree.pvb_pat = pvb_pat; - From.Parsetree.pvb_expr = pvb_expr; - From.Parsetree.pvb_attributes = pvb_attributes; - From.Parsetree.pvb_loc = pvb_loc } - -> - { - To.Parsetree.pvb_pat = (copy_pattern pvb_pat); - To.Parsetree.pvb_expr = - (copy_expression pvb_expr); - To.Parsetree.pvb_attributes = - (copy_attributes pvb_attributes); - To.Parsetree.pvb_loc = (copy_location pvb_loc) - } - -and copy_pattern : - From.Parsetree.pattern -> To.Parsetree.pattern = - fun - { From.Parsetree.ppat_desc = ppat_desc; - From.Parsetree.ppat_loc = ppat_loc; - From.Parsetree.ppat_attributes = ppat_attributes } - -> - { - To.Parsetree.ppat_desc = - (copy_pattern_desc ppat_desc); - To.Parsetree.ppat_loc = (copy_location ppat_loc); - To.Parsetree.ppat_attributes = - (copy_attributes ppat_attributes) - } - -and copy_pattern_desc : - From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc = - function - | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any - | From.Parsetree.Ppat_var x0 -> - To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_alias (x0,x1) -> - To.Parsetree.Ppat_alias - ((copy_pattern x0), - (copy_loc (fun x -> x) x1)) - | From.Parsetree.Ppat_constant x0 -> - To.Parsetree.Ppat_constant (copy_constant x0) - | From.Parsetree.Ppat_interval (x0,x1) -> - To.Parsetree.Ppat_interval - ((copy_constant x0), - (copy_constant x1)) - | From.Parsetree.Ppat_tuple x0 -> - To.Parsetree.Ppat_tuple - (List.map copy_pattern x0) - | From.Parsetree.Ppat_construct (x0,x1) -> - To.Parsetree.Ppat_construct - ((copy_loc copy_longident x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_variant (x0,x1) -> - To.Parsetree.Ppat_variant - ((copy_label x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_record (x0,x1) -> - To.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ppat_array x0 -> - To.Parsetree.Ppat_array - (List.map copy_pattern x0) - | From.Parsetree.Ppat_or (x0,x1) -> - To.Parsetree.Ppat_or - ((copy_pattern x0), - (copy_pattern x1)) - | From.Parsetree.Ppat_constraint (x0,x1) -> - To.Parsetree.Ppat_constraint - ((copy_pattern x0), - (copy_core_type x1)) - | From.Parsetree.Ppat_type x0 -> - To.Parsetree.Ppat_type - (copy_loc copy_longident x0) - | From.Parsetree.Ppat_lazy x0 -> - To.Parsetree.Ppat_lazy (copy_pattern x0) - | From.Parsetree.Ppat_unpack x0 -> - To.Parsetree.Ppat_unpack - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_exception x0 -> - To.Parsetree.Ppat_exception (copy_pattern x0) - | From.Parsetree.Ppat_extension x0 -> - To.Parsetree.Ppat_extension (copy_extension x0) - | From.Parsetree.Ppat_open (x0,x1) -> - To.Parsetree.Ppat_open - ((copy_loc copy_longident x0), - (copy_pattern x1)) - -and copy_core_type : - From.Parsetree.core_type -> To.Parsetree.core_type = - fun - { From.Parsetree.ptyp_desc = ptyp_desc; - From.Parsetree.ptyp_loc = ptyp_loc; - From.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - To.Parsetree.ptyp_desc = - (copy_core_type_desc ptyp_desc); - To.Parsetree.ptyp_loc = (copy_location ptyp_loc); - To.Parsetree.ptyp_attributes = - (copy_attributes ptyp_attributes) - } - -and copy_core_type_desc : - From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = - function - | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any - | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 - | From.Parsetree.Ptyp_arrow (x0,x1,x2) -> - To.Parsetree.Ptyp_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Ptyp_tuple x0 -> - To.Parsetree.Ptyp_tuple - (List.map copy_core_type x0) - | From.Parsetree.Ptyp_constr (x0,x1) -> - To.Parsetree.Ptyp_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_object (x0,x1) -> - To.Parsetree.Ptyp_object - ((List.map - (fun x -> - let (x0,x1,x2) = x in - (x0.From.Asttypes.txt, (copy_attributes x1), - (copy_core_type x2))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ptyp_class (x0,x1) -> - To.Parsetree.Ptyp_class - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_alias (x0,x1) -> - To.Parsetree.Ptyp_alias - ((copy_core_type x0), x1) - | From.Parsetree.Ptyp_variant (x0,x1,x2) -> - To.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), - (copy_closed_flag x1), - (copy_option (fun x -> List.map copy_label x) x2)) - | From.Parsetree.Ptyp_poly (x0,x1) -> - To.Parsetree.Ptyp_poly - ((List.map (fun x -> x.From.Asttypes.txt) x0), (copy_core_type x1)) - | From.Parsetree.Ptyp_package x0 -> - To.Parsetree.Ptyp_package (copy_package_type x0) - | From.Parsetree.Ptyp_extension x0 -> - To.Parsetree.Ptyp_extension (copy_extension x0) - -and copy_package_type : - From.Parsetree.package_type -> To.Parsetree.package_type = - fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_core_type x1))) x1)) - -and copy_row_field : - From.Parsetree.row_field -> To.Parsetree.row_field = - function - | From.Parsetree.Rtag (x0,x1,x2,x3) -> - To.Parsetree.Rtag - ((copy_label x0), - (copy_attributes x1), (copy_bool x2), - (List.map copy_core_type x3)) - | From.Parsetree.Rinherit x0 -> - To.Parsetree.Rinherit (copy_core_type x0) - -and copy_attributes : - From.Parsetree.attributes -> To.Parsetree.attributes = - fun x -> List.map copy_attribute x - -and copy_attribute : - From.Parsetree.attribute -> To.Parsetree.attribute = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_payload : - From.Parsetree.payload -> To.Parsetree.payload = - function - | From.Parsetree.PStr x0 -> - To.Parsetree.PStr (copy_structure x0) - | From.Parsetree.PSig x0 -> - To.Parsetree.PSig (copy_signature x0) - | From.Parsetree.PTyp x0 -> - To.Parsetree.PTyp (copy_core_type x0) - | From.Parsetree.PPat (x0,x1) -> - To.Parsetree.PPat - ((copy_pattern x0), - (copy_option copy_expression x1)) - -and copy_structure : - From.Parsetree.structure -> To.Parsetree.structure = - fun x -> List.map copy_structure_item x - -and copy_structure_item : - From.Parsetree.structure_item -> To.Parsetree.structure_item = - fun - { From.Parsetree.pstr_desc = pstr_desc; - From.Parsetree.pstr_loc = pstr_loc } - -> - { - To.Parsetree.pstr_desc = - (copy_structure_item_desc pstr_desc); - To.Parsetree.pstr_loc = (copy_location pstr_loc) - } - -and copy_structure_item_desc : - From.Parsetree.structure_item_desc -> - To.Parsetree.structure_item_desc - = - function - | From.Parsetree.Pstr_eval (x0,x1) -> - To.Parsetree.Pstr_eval - ((copy_expression x0), - (copy_attributes x1)) - | From.Parsetree.Pstr_value (x0,x1) -> - To.Parsetree.Pstr_value - ((copy_rec_flag x0), - (List.map copy_value_binding x1)) - | From.Parsetree.Pstr_primitive x0 -> - To.Parsetree.Pstr_primitive - (copy_value_description x0) - | From.Parsetree.Pstr_type (x0,x1) -> - To.Parsetree.Pstr_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Pstr_typext x0 -> - To.Parsetree.Pstr_typext - (copy_type_extension x0) - | From.Parsetree.Pstr_exception x0 -> - To.Parsetree.Pstr_exception - (copy_extension_constructor x0) - | From.Parsetree.Pstr_module x0 -> - To.Parsetree.Pstr_module - (copy_module_binding x0) - | From.Parsetree.Pstr_recmodule x0 -> - To.Parsetree.Pstr_recmodule - (List.map copy_module_binding x0) - | From.Parsetree.Pstr_modtype x0 -> - To.Parsetree.Pstr_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Pstr_open x0 -> - To.Parsetree.Pstr_open - (copy_open_description x0) - | From.Parsetree.Pstr_class x0 -> - To.Parsetree.Pstr_class - (List.map copy_class_declaration x0) - | From.Parsetree.Pstr_class_type x0 -> - To.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Pstr_include x0 -> - To.Parsetree.Pstr_include - (copy_include_declaration x0) - | From.Parsetree.Pstr_attribute x0 -> - To.Parsetree.Pstr_attribute (copy_attribute x0) - | From.Parsetree.Pstr_extension (x0,x1) -> - To.Parsetree.Pstr_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_include_declaration : - From.Parsetree.include_declaration -> - To.Parsetree.include_declaration - = - fun x -> - copy_include_infos copy_module_expr x - -and copy_class_declaration : - From.Parsetree.class_declaration -> To.Parsetree.class_declaration - = - fun x -> - copy_class_infos copy_class_expr x - -and copy_class_expr : - From.Parsetree.class_expr -> To.Parsetree.class_expr = - fun - { From.Parsetree.pcl_desc = pcl_desc; - From.Parsetree.pcl_loc = pcl_loc; - From.Parsetree.pcl_attributes = pcl_attributes } - -> - { - To.Parsetree.pcl_desc = - (copy_class_expr_desc pcl_desc); - To.Parsetree.pcl_loc = (copy_location pcl_loc); - To.Parsetree.pcl_attributes = - (copy_attributes pcl_attributes) - } - -and copy_class_expr_desc : - From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = - function - | From.Parsetree.Pcl_constr (x0,x1) -> - To.Parsetree.Pcl_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcl_structure x0 -> - To.Parsetree.Pcl_structure - (copy_class_structure x0) - | From.Parsetree.Pcl_fun (x0,x1,x2,x3) -> - To.Parsetree.Pcl_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_class_expr x3)) - | From.Parsetree.Pcl_apply (x0,x1) -> - To.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pcl_let (x0,x1,x2) -> - To.Parsetree.Pcl_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_class_expr x2)) - | From.Parsetree.Pcl_constraint (x0,x1) -> - To.Parsetree.Pcl_constraint - ((copy_class_expr x0), - (copy_class_type x1)) - | From.Parsetree.Pcl_extension x0 -> - To.Parsetree.Pcl_extension (copy_extension x0) - -and copy_class_structure : - From.Parsetree.class_structure -> To.Parsetree.class_structure = - fun - { From.Parsetree.pcstr_self = pcstr_self; - From.Parsetree.pcstr_fields = pcstr_fields } - -> - { - To.Parsetree.pcstr_self = - (copy_pattern pcstr_self); - To.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } - -and copy_class_field : - From.Parsetree.class_field -> To.Parsetree.class_field = - fun - { From.Parsetree.pcf_desc = pcf_desc; - From.Parsetree.pcf_loc = pcf_loc; - From.Parsetree.pcf_attributes = pcf_attributes } - -> - { - To.Parsetree.pcf_desc = - (copy_class_field_desc pcf_desc); - To.Parsetree.pcf_loc = (copy_location pcf_loc); - To.Parsetree.pcf_attributes = - (copy_attributes pcf_attributes) - } - -and copy_class_field_desc : - From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = - function - | From.Parsetree.Pcf_inherit (x0,x1,x2) -> - To.Parsetree.Pcf_inherit - ((copy_override_flag x0), - (copy_class_expr x1), - (copy_option (fun x -> x.From.Asttypes.txt) x2)) - | From.Parsetree.Pcf_val x0 -> - To.Parsetree.Pcf_val - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_method x0 -> - To.Parsetree.Pcf_method - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_private_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_constraint x0 -> - To.Parsetree.Pcf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pcf_initializer x0 -> - To.Parsetree.Pcf_initializer - (copy_expression x0) - | From.Parsetree.Pcf_attribute x0 -> - To.Parsetree.Pcf_attribute (copy_attribute x0) - | From.Parsetree.Pcf_extension x0 -> - To.Parsetree.Pcf_extension (copy_extension x0) - -and copy_class_field_kind : - From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = - function - | From.Parsetree.Cfk_virtual x0 -> - To.Parsetree.Cfk_virtual (copy_core_type x0) - | From.Parsetree.Cfk_concrete (x0,x1) -> - To.Parsetree.Cfk_concrete - ((copy_override_flag x0), - (copy_expression x1)) - -and copy_module_binding : - From.Parsetree.module_binding -> To.Parsetree.module_binding = - fun - { From.Parsetree.pmb_name = pmb_name; - From.Parsetree.pmb_expr = pmb_expr; - From.Parsetree.pmb_attributes = pmb_attributes; - From.Parsetree.pmb_loc = pmb_loc } - -> - { - To.Parsetree.pmb_name = - (copy_loc (fun x -> x) pmb_name); - To.Parsetree.pmb_expr = - (copy_module_expr pmb_expr); - To.Parsetree.pmb_attributes = - (copy_attributes pmb_attributes); - To.Parsetree.pmb_loc = (copy_location pmb_loc) - } - -and copy_module_expr : - From.Parsetree.module_expr -> To.Parsetree.module_expr = - fun - { From.Parsetree.pmod_desc = pmod_desc; - From.Parsetree.pmod_loc = pmod_loc; - From.Parsetree.pmod_attributes = pmod_attributes } - -> - { - To.Parsetree.pmod_desc = - (copy_module_expr_desc pmod_desc); - To.Parsetree.pmod_loc = (copy_location pmod_loc); - To.Parsetree.pmod_attributes = - (copy_attributes pmod_attributes) - } - -and copy_module_expr_desc : - From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = - function - | From.Parsetree.Pmod_ident x0 -> - To.Parsetree.Pmod_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmod_structure x0 -> - To.Parsetree.Pmod_structure (copy_structure x0) - | From.Parsetree.Pmod_functor (x0,x1,x2) -> - To.Parsetree.Pmod_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_expr x2)) - | From.Parsetree.Pmod_apply (x0,x1) -> - To.Parsetree.Pmod_apply - ((copy_module_expr x0), - (copy_module_expr x1)) - | From.Parsetree.Pmod_constraint (x0,x1) -> - To.Parsetree.Pmod_constraint - ((copy_module_expr x0), - (copy_module_type x1)) - | From.Parsetree.Pmod_unpack x0 -> - To.Parsetree.Pmod_unpack (copy_expression x0) - | From.Parsetree.Pmod_extension x0 -> - To.Parsetree.Pmod_extension (copy_extension x0) - -and copy_module_type : - From.Parsetree.module_type -> To.Parsetree.module_type = - fun - { From.Parsetree.pmty_desc = pmty_desc; - From.Parsetree.pmty_loc = pmty_loc; - From.Parsetree.pmty_attributes = pmty_attributes } - -> - { - To.Parsetree.pmty_desc = - (copy_module_type_desc pmty_desc); - To.Parsetree.pmty_loc = (copy_location pmty_loc); - To.Parsetree.pmty_attributes = - (copy_attributes pmty_attributes) - } - -and copy_module_type_desc : - From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = - function - | From.Parsetree.Pmty_ident x0 -> - To.Parsetree.Pmty_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmty_signature x0 -> - To.Parsetree.Pmty_signature (copy_signature x0) - | From.Parsetree.Pmty_functor (x0,x1,x2) -> - To.Parsetree.Pmty_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_type x2)) - | From.Parsetree.Pmty_with (x0,x1) -> - To.Parsetree.Pmty_with - ((copy_module_type x0), - (List.map copy_with_constraint x1)) - | From.Parsetree.Pmty_typeof x0 -> - To.Parsetree.Pmty_typeof (copy_module_expr x0) - | From.Parsetree.Pmty_extension x0 -> - To.Parsetree.Pmty_extension (copy_extension x0) - | From.Parsetree.Pmty_alias x0 -> - To.Parsetree.Pmty_alias - (copy_loc copy_longident x0) - -and copy_with_constraint : - From.Parsetree.with_constraint -> To.Parsetree.with_constraint = - function - | From.Parsetree.Pwith_type (x0,x1) -> - To.Parsetree.Pwith_type - ((copy_loc copy_longident x0), - (copy_type_declaration x1)) - | From.Parsetree.Pwith_module (x0,x1) -> - To.Parsetree.Pwith_module - ((copy_loc copy_longident x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pwith_typesubst x0 -> - To.Parsetree.Pwith_typesubst - (copy_type_declaration x0) - | From.Parsetree.Pwith_modsubst (x0,x1) -> - To.Parsetree.Pwith_modsubst - ((copy_loc (fun x -> x) x0), - (copy_loc copy_longident x1)) - -and copy_signature : - From.Parsetree.signature -> To.Parsetree.signature = - fun x -> List.map copy_signature_item x - -and copy_signature_item : - From.Parsetree.signature_item -> To.Parsetree.signature_item = - fun - { From.Parsetree.psig_desc = psig_desc; - From.Parsetree.psig_loc = psig_loc } - -> - { - To.Parsetree.psig_desc = - (copy_signature_item_desc psig_desc); - To.Parsetree.psig_loc = (copy_location psig_loc) - } - -and copy_signature_item_desc : - From.Parsetree.signature_item_desc -> - To.Parsetree.signature_item_desc - = - function - | From.Parsetree.Psig_value x0 -> - To.Parsetree.Psig_value - (copy_value_description x0) - | From.Parsetree.Psig_type (x0,x1) -> - To.Parsetree.Psig_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Psig_typext x0 -> - To.Parsetree.Psig_typext - (copy_type_extension x0) - | From.Parsetree.Psig_exception x0 -> - To.Parsetree.Psig_exception - (copy_extension_constructor x0) - | From.Parsetree.Psig_module x0 -> - To.Parsetree.Psig_module - (copy_module_declaration x0) - | From.Parsetree.Psig_recmodule x0 -> - To.Parsetree.Psig_recmodule - (List.map copy_module_declaration x0) - | From.Parsetree.Psig_modtype x0 -> - To.Parsetree.Psig_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Psig_open x0 -> - To.Parsetree.Psig_open - (copy_open_description x0) - | From.Parsetree.Psig_include x0 -> - To.Parsetree.Psig_include - (copy_include_description x0) - | From.Parsetree.Psig_class x0 -> - To.Parsetree.Psig_class - (List.map copy_class_description x0) - | From.Parsetree.Psig_class_type x0 -> - To.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Psig_attribute x0 -> - To.Parsetree.Psig_attribute (copy_attribute x0) - | From.Parsetree.Psig_extension (x0,x1) -> - To.Parsetree.Psig_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_class_type_declaration : - From.Parsetree.class_type_declaration -> - To.Parsetree.class_type_declaration - = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_description : - From.Parsetree.class_description -> To.Parsetree.class_description - = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_type : - From.Parsetree.class_type -> To.Parsetree.class_type = - fun - { From.Parsetree.pcty_desc = pcty_desc; - From.Parsetree.pcty_loc = pcty_loc; - From.Parsetree.pcty_attributes = pcty_attributes } - -> - { - To.Parsetree.pcty_desc = - (copy_class_type_desc pcty_desc); - To.Parsetree.pcty_loc = (copy_location pcty_loc); - To.Parsetree.pcty_attributes = - (copy_attributes pcty_attributes) - } - -and copy_class_type_desc : - From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = - function - | From.Parsetree.Pcty_constr (x0,x1) -> - To.Parsetree.Pcty_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcty_signature x0 -> - To.Parsetree.Pcty_signature - (copy_class_signature x0) - | From.Parsetree.Pcty_arrow (x0,x1,x2) -> - To.Parsetree.Pcty_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_class_type x2)) - | From.Parsetree.Pcty_extension x0 -> - To.Parsetree.Pcty_extension (copy_extension x0) - -and copy_class_signature : - From.Parsetree.class_signature -> To.Parsetree.class_signature = - fun - { From.Parsetree.pcsig_self = pcsig_self; - From.Parsetree.pcsig_fields = pcsig_fields } - -> - { - To.Parsetree.pcsig_self = - (copy_core_type pcsig_self); - To.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } - -and copy_class_type_field : - From.Parsetree.class_type_field -> To.Parsetree.class_type_field = - fun - { From.Parsetree.pctf_desc = pctf_desc; - From.Parsetree.pctf_loc = pctf_loc; - From.Parsetree.pctf_attributes = pctf_attributes } - -> - { - To.Parsetree.pctf_desc = - (copy_class_type_field_desc pctf_desc); - To.Parsetree.pctf_loc = (copy_location pctf_loc); - To.Parsetree.pctf_attributes = - (copy_attributes pctf_attributes) - } - -and copy_class_type_field_desc : - From.Parsetree.class_type_field_desc -> - To.Parsetree.class_type_field_desc - = - function - | From.Parsetree.Pctf_inherit x0 -> - To.Parsetree.Pctf_inherit (copy_class_type x0) - | From.Parsetree.Pctf_val x0 -> - To.Parsetree.Pctf_val - (let (x0,x1,x2,x3) = x0 in - (x0.From.Asttypes.txt, (copy_mutable_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_method x0 -> - To.Parsetree.Pctf_method - (let (x0,x1,x2,x3) = x0 in - (x0.From.Asttypes.txt, (copy_private_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_constraint x0 -> - To.Parsetree.Pctf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pctf_attribute x0 -> - To.Parsetree.Pctf_attribute (copy_attribute x0) - | From.Parsetree.Pctf_extension x0 -> - To.Parsetree.Pctf_extension (copy_extension x0) - -and copy_extension : - From.Parsetree.extension -> To.Parsetree.extension = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.class_infos -> 'g0 To.Parsetree.class_infos - = - fun f0 -> - fun - { From.Parsetree.pci_virt = pci_virt; - From.Parsetree.pci_params = pci_params; - From.Parsetree.pci_name = pci_name; - From.Parsetree.pci_expr = pci_expr; - From.Parsetree.pci_loc = pci_loc; - From.Parsetree.pci_attributes = pci_attributes } - -> - { - To.Parsetree.pci_virt = - (copy_virtual_flag pci_virt); - To.Parsetree.pci_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) pci_params); - To.Parsetree.pci_name = - (copy_loc (fun x -> x) pci_name); - To.Parsetree.pci_expr = (f0 pci_expr); - To.Parsetree.pci_loc = (copy_location pci_loc); - To.Parsetree.pci_attributes = - (copy_attributes pci_attributes) - } - -and copy_virtual_flag : - From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = - function - | From.Asttypes.Virtual -> To.Asttypes.Virtual - | From.Asttypes.Concrete -> To.Asttypes.Concrete - -and copy_include_description : - From.Parsetree.include_description -> - To.Parsetree.include_description - = - fun x -> - copy_include_infos copy_module_type x - -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.include_infos -> - 'g0 To.Parsetree.include_infos - = - fun f0 -> - fun - { From.Parsetree.pincl_mod = pincl_mod; - From.Parsetree.pincl_loc = pincl_loc; - From.Parsetree.pincl_attributes = pincl_attributes } - -> - { - To.Parsetree.pincl_mod = (f0 pincl_mod); - To.Parsetree.pincl_loc = (copy_location pincl_loc); - To.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } - -and copy_open_description : - From.Parsetree.open_description -> To.Parsetree.open_description = - fun - { From.Parsetree.popen_lid = popen_lid; - From.Parsetree.popen_override = popen_override; - From.Parsetree.popen_loc = popen_loc; - From.Parsetree.popen_attributes = popen_attributes } - -> - { - To.Parsetree.popen_lid = - (copy_loc copy_longident popen_lid); - To.Parsetree.popen_override = - (copy_override_flag popen_override); - To.Parsetree.popen_loc = (copy_location popen_loc); - To.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } - -and copy_override_flag : - From.Asttypes.override_flag -> To.Asttypes.override_flag = - function - | From.Asttypes.Override -> To.Asttypes.Override - | From.Asttypes.Fresh -> To.Asttypes.Fresh - -and copy_module_type_declaration : - From.Parsetree.module_type_declaration -> - To.Parsetree.module_type_declaration +let rec copy_out_type_extension : + Ast_405.Outcometree.out_type_extension -> + Ast_404.Outcometree.out_type_extension = fun - { From.Parsetree.pmtd_name = pmtd_name; - From.Parsetree.pmtd_type = pmtd_type; - From.Parsetree.pmtd_attributes = pmtd_attributes; - From.Parsetree.pmtd_loc = pmtd_loc } - -> + { Ast_405.Outcometree.otyext_name = otyext_name; + Ast_405.Outcometree.otyext_params = otyext_params; + Ast_405.Outcometree.otyext_constructors = otyext_constructors; + Ast_405.Outcometree.otyext_private = otyext_private } + -> { - To.Parsetree.pmtd_name = - (copy_loc (fun x -> x) pmtd_name); - To.Parsetree.pmtd_type = - (copy_option copy_module_type pmtd_type); - To.Parsetree.pmtd_attributes = - (copy_attributes pmtd_attributes); - To.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } - -and copy_module_declaration : - From.Parsetree.module_declaration -> - To.Parsetree.module_declaration - = - fun - { From.Parsetree.pmd_name = pmd_name; - From.Parsetree.pmd_type = pmd_type; - From.Parsetree.pmd_attributes = pmd_attributes; - From.Parsetree.pmd_loc = pmd_loc } - -> - { - To.Parsetree.pmd_name = - (copy_loc (fun x -> x) pmd_name); - To.Parsetree.pmd_type = - (copy_module_type pmd_type); - To.Parsetree.pmd_attributes = - (copy_attributes pmd_attributes); - To.Parsetree.pmd_loc = (copy_location pmd_loc) - } - -and copy_type_extension : - From.Parsetree.type_extension -> To.Parsetree.type_extension = - fun - { From.Parsetree.ptyext_path = ptyext_path; - From.Parsetree.ptyext_params = ptyext_params; - From.Parsetree.ptyext_constructors = ptyext_constructors; - From.Parsetree.ptyext_private = ptyext_private; - From.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - To.Parsetree.ptyext_path = - (copy_loc copy_longident ptyext_path); - To.Parsetree.ptyext_params = + Ast_404.Outcometree.otyext_name = otyext_name; + Ast_404.Outcometree.otyext_params = + (List.map (fun x -> x) otyext_params); + Ast_404.Outcometree.otyext_constructors = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptyext_params); - To.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor - ptyext_constructors); - To.Parsetree.ptyext_private = - (copy_private_flag ptyext_private); - To.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } - -and copy_extension_constructor : - From.Parsetree.extension_constructor -> - To.Parsetree.extension_constructor - = - fun - { From.Parsetree.pext_name = pext_name; - From.Parsetree.pext_kind = pext_kind; - From.Parsetree.pext_loc = pext_loc; - From.Parsetree.pext_attributes = pext_attributes } - -> - { - To.Parsetree.pext_name = - (copy_loc (fun x -> x) pext_name); - To.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - To.Parsetree.pext_loc = (copy_location pext_loc); - To.Parsetree.pext_attributes = - (copy_attributes pext_attributes) - } - -and copy_extension_constructor_kind : - From.Parsetree.extension_constructor_kind -> - To.Parsetree.extension_constructor_kind - = - function - | From.Parsetree.Pext_decl (x0,x1) -> - To.Parsetree.Pext_decl - ((copy_constructor_arguments x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pext_rebind x0 -> - To.Parsetree.Pext_rebind - (copy_loc copy_longident x0) - -and copy_type_declaration : - From.Parsetree.type_declaration -> To.Parsetree.type_declaration = - fun - { From.Parsetree.ptype_name = ptype_name; - From.Parsetree.ptype_params = ptype_params; - From.Parsetree.ptype_cstrs = ptype_cstrs; - From.Parsetree.ptype_kind = ptype_kind; - From.Parsetree.ptype_private = ptype_private; - From.Parsetree.ptype_manifest = ptype_manifest; - From.Parsetree.ptype_attributes = ptype_attributes; - From.Parsetree.ptype_loc = ptype_loc } - -> - { - To.Parsetree.ptype_name = - (copy_loc (fun x -> x) ptype_name); - To.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptype_params); - To.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0,x1,x2) = x in - ((copy_core_type x0), - (copy_core_type x1), - (copy_location x2))) ptype_cstrs); - To.Parsetree.ptype_kind = - (copy_type_kind ptype_kind); - To.Parsetree.ptype_private = - (copy_private_flag ptype_private); - To.Parsetree.ptype_manifest = - (copy_option copy_core_type ptype_manifest); - To.Parsetree.ptype_attributes = - (copy_attributes ptype_attributes); - To.Parsetree.ptype_loc = (copy_location ptype_loc) - } - -and copy_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = - function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - -and copy_type_kind : - From.Parsetree.type_kind -> To.Parsetree.type_kind = - function - | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract - | From.Parsetree.Ptype_variant x0 -> - To.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | From.Parsetree.Ptype_record x0 -> - To.Parsetree.Ptype_record - (List.map copy_label_declaration x0) - | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open - -and copy_constructor_declaration : - From.Parsetree.constructor_declaration -> - To.Parsetree.constructor_declaration - = - fun - { From.Parsetree.pcd_name = pcd_name; - From.Parsetree.pcd_args = pcd_args; - From.Parsetree.pcd_res = pcd_res; - From.Parsetree.pcd_loc = pcd_loc; - From.Parsetree.pcd_attributes = pcd_attributes } - -> - { - To.Parsetree.pcd_name = - (copy_loc (fun x -> x) pcd_name); - To.Parsetree.pcd_args = - (copy_constructor_arguments pcd_args); - To.Parsetree.pcd_res = - (copy_option copy_core_type pcd_res); - To.Parsetree.pcd_loc = (copy_location pcd_loc); - To.Parsetree.pcd_attributes = - (copy_attributes pcd_attributes) - } - -and copy_constructor_arguments : - From.Parsetree.constructor_arguments -> - To.Parsetree.constructor_arguments - = - function - | From.Parsetree.Pcstr_tuple x0 -> - To.Parsetree.Pcstr_tuple - (List.map copy_core_type x0) - | From.Parsetree.Pcstr_record x0 -> - To.Parsetree.Pcstr_record - (List.map copy_label_declaration x0) - -and copy_label_declaration : - From.Parsetree.label_declaration -> To.Parsetree.label_declaration - = - fun - { From.Parsetree.pld_name = pld_name; - From.Parsetree.pld_mutable = pld_mutable; - From.Parsetree.pld_type = pld_type; - From.Parsetree.pld_loc = pld_loc; - From.Parsetree.pld_attributes = pld_attributes } - -> - { - To.Parsetree.pld_name = - (copy_loc (fun x -> x) pld_name); - To.Parsetree.pld_mutable = - (copy_mutable_flag pld_mutable); - To.Parsetree.pld_type = - (copy_core_type pld_type); - To.Parsetree.pld_loc = (copy_location pld_loc); - To.Parsetree.pld_attributes = - (copy_attributes pld_attributes) - } - -and copy_mutable_flag : - From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = - function - | From.Asttypes.Immutable -> To.Asttypes.Immutable - | From.Asttypes.Mutable -> To.Asttypes.Mutable - -and copy_variance : - From.Asttypes.variance -> To.Asttypes.variance = - function - | From.Asttypes.Covariant -> To.Asttypes.Covariant - | From.Asttypes.Contravariant -> To.Asttypes.Contravariant - | From.Asttypes.Invariant -> To.Asttypes.Invariant - -and copy_value_description : - From.Parsetree.value_description -> To.Parsetree.value_description - = - fun - { From.Parsetree.pval_name = pval_name; - From.Parsetree.pval_type = pval_type; - From.Parsetree.pval_prim = pval_prim; - From.Parsetree.pval_attributes = pval_attributes; - From.Parsetree.pval_loc = pval_loc } - -> - { - To.Parsetree.pval_name = - (copy_loc (fun x -> x) pval_name); - To.Parsetree.pval_type = - (copy_core_type pval_type); - To.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - To.Parsetree.pval_attributes = - (copy_attributes pval_attributes); - To.Parsetree.pval_loc = (copy_location pval_loc) - } - -and copy_arg_label : - From.Asttypes.arg_label -> To.Asttypes.arg_label = - function - | From.Asttypes.Nolabel -> To.Asttypes.Nolabel - | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 - | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 - -and copy_closed_flag : - From.Asttypes.closed_flag -> To.Asttypes.closed_flag = - function - | From.Asttypes.Closed -> To.Asttypes.Closed - | From.Asttypes.Open -> To.Asttypes.Open - -and copy_label : - From.Asttypes.label -> To.Asttypes.label = fun x -> x - -and copy_rec_flag : - From.Asttypes.rec_flag -> To.Asttypes.rec_flag = - function - | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive - | From.Asttypes.Recursive -> To.Asttypes.Recursive - -and copy_constant : - From.Parsetree.constant -> To.Parsetree.constant = - function - | From.Parsetree.Pconst_integer (x0,x1) -> - To.Parsetree.Pconst_integer (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 - | From.Parsetree.Pconst_string (x0,x1) -> - To.Parsetree.Pconst_string (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_float (x0,x1) -> - To.Parsetree.Pconst_float (x0, (copy_option (fun x -> x) x1)) - -and copy_option : 'f0 'g0 . ('f0 -> 'g0) -> 'f0 option -> 'g0 option = - fun f0 -> function | None -> None | Some x0 -> Some (f0 x0) - -and copy_longident : From.Longident.t -> To.Longident.t = - function - | From.Longident.Lident x0 -> To.Longident.Lident x0 - | From.Longident.Ldot (x0,x1) -> - To.Longident.Ldot ((copy_longident x0), x1) - | From.Longident.Lapply (x0,x1) -> - To.Longident.Lapply - ((copy_longident x0), (copy_longident x1)) - -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc - = - fun f0 -> - fun { From.Asttypes.txt = txt; From.Asttypes.loc = loc } -> - { - To.Asttypes.txt = (f0 txt); - To.Asttypes.loc = (copy_location loc) - } - -and copy_location : From.Location.t -> To.Location.t = - fun - { From.Location.loc_start = loc_start; - From.Location.loc_end = loc_end; - From.Location.loc_ghost = loc_ghost } - -> - { - To.Location.loc_start = (copy_Lexing_position loc_start); - To.Location.loc_end = (copy_Lexing_position loc_end); - To.Location.loc_ghost = (copy_bool loc_ghost) - } - -and copy_bool : bool -> bool = function | false -> false | true -> true - -and copy_Lexing_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum + (fun x -> + let (x0, x1, x2) = x in + (x0, (List.map copy_out_type x1), + (Option.map copy_out_type x2))) otyext_constructors); + Ast_404.Outcometree.otyext_private = (copy_private_flag otyext_private) } - -let rec copy_out_phrase : - From.Outcometree.out_phrase -> To.Outcometree.out_phrase = +and copy_out_phrase : + Ast_405.Outcometree.out_phrase -> Ast_404.Outcometree.out_phrase = function - | From.Outcometree.Ophr_eval (x0,x1) -> - To.Outcometree.Ophr_eval - ((copy_out_value x0), - (copy_out_type x1)) - | From.Outcometree.Ophr_signature x0 -> - To.Outcometree.Ophr_signature + | Ast_405.Outcometree.Ophr_eval (x0, x1) -> + Ast_404.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1)) + | Ast_405.Outcometree.Ophr_signature x0 -> + Ast_404.Outcometree.Ophr_signature (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_sig_item x0), - (copy_option copy_out_value x1))) x0) - | From.Outcometree.Ophr_exception x0 -> - To.Outcometree.Ophr_exception - (let (x0,x1) = x0 in - ((copy_exn x0), (copy_out_value x1))) - -and copy_exn : exn -> exn = fun x -> x - + (fun x -> + let (x0, x1) = x in + ((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0) + | Ast_405.Outcometree.Ophr_exception x0 -> + Ast_404.Outcometree.Ophr_exception + (let (x0, x1) = x0 in (x0, (copy_out_value x1))) and copy_out_sig_item : - From.Outcometree.out_sig_item -> To.Outcometree.out_sig_item = + Ast_405.Outcometree.out_sig_item -> Ast_404.Outcometree.out_sig_item = function - | From.Outcometree.Osig_class (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class - ((copy_bool x0), x1, + | Ast_405.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> + Ast_404.Outcometree.Osig_class + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_class_type (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class_type - ((copy_bool x0), x1, + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_405.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> + Ast_404.Outcometree.Osig_class_type + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_typext (x0,x1) -> - To.Outcometree.Osig_typext - ((copy_out_extension_constructor x0), - (copy_out_ext_status x1)) - | From.Outcometree.Osig_modtype (x0,x1) -> - To.Outcometree.Osig_modtype - (x0, (copy_out_module_type x1)) - | From.Outcometree.Osig_module (x0,x1,x2) -> - To.Outcometree.Osig_module - (x0, (copy_out_module_type x1), - (copy_out_rec_status x2)) - | From.Outcometree.Osig_type (x0,x1) -> - To.Outcometree.Osig_type - ((copy_out_type_decl x0), - (copy_out_rec_status x1)) - | From.Outcometree.Osig_value x0 -> - To.Outcometree.Osig_value - (copy_out_val_decl x0) - | From.Outcometree.Osig_ellipsis -> To.Outcometree.Osig_ellipsis - + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_405.Outcometree.Osig_typext (x0, x1) -> + Ast_404.Outcometree.Osig_typext + ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) + | Ast_405.Outcometree.Osig_modtype (x0, x1) -> + Ast_404.Outcometree.Osig_modtype (x0, (copy_out_module_type x1)) + | Ast_405.Outcometree.Osig_module (x0, x1, x2) -> + Ast_404.Outcometree.Osig_module + (x0, (copy_out_module_type x1), (copy_out_rec_status x2)) + | Ast_405.Outcometree.Osig_type (x0, x1) -> + Ast_404.Outcometree.Osig_type + ((copy_out_type_decl x0), (copy_out_rec_status x1)) + | Ast_405.Outcometree.Osig_value x0 -> + Ast_404.Outcometree.Osig_value (copy_out_val_decl x0) + | Ast_405.Outcometree.Osig_ellipsis -> Ast_404.Outcometree.Osig_ellipsis and copy_out_val_decl : - From.Outcometree.out_val_decl -> To.Outcometree.out_val_decl = + Ast_405.Outcometree.out_val_decl -> Ast_404.Outcometree.out_val_decl = fun - { From.Outcometree.oval_name = oval_name; - From.Outcometree.oval_type = oval_type; - From.Outcometree.oval_prims = oval_prims; - From.Outcometree.oval_attributes = oval_attributes } - -> + { Ast_405.Outcometree.oval_name = oval_name; + Ast_405.Outcometree.oval_type = oval_type; + Ast_405.Outcometree.oval_prims = oval_prims; + Ast_405.Outcometree.oval_attributes = oval_attributes } + -> { - To.Outcometree.oval_name = oval_name; - To.Outcometree.oval_type = - (copy_out_type oval_type); - To.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); - To.Outcometree.oval_attributes = + Ast_404.Outcometree.oval_name = oval_name; + Ast_404.Outcometree.oval_type = (copy_out_type oval_type); + Ast_404.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); + Ast_404.Outcometree.oval_attributes = (List.map copy_out_attribute oval_attributes) } - and copy_out_type_decl : - From.Outcometree.out_type_decl -> To.Outcometree.out_type_decl = + Ast_405.Outcometree.out_type_decl -> Ast_404.Outcometree.out_type_decl = fun - { From.Outcometree.otype_name = otype_name; - From.Outcometree.otype_params = otype_params; - From.Outcometree.otype_type = otype_type; - From.Outcometree.otype_private = otype_private; - From.Outcometree.otype_immediate = otype_immediate; - From.Outcometree.otype_unboxed = otype_unboxed; - From.Outcometree.otype_cstrs = otype_cstrs } - -> + { Ast_405.Outcometree.otype_name = otype_name; + Ast_405.Outcometree.otype_params = otype_params; + Ast_405.Outcometree.otype_type = otype_type; + Ast_405.Outcometree.otype_private = otype_private; + Ast_405.Outcometree.otype_immediate = otype_immediate; + Ast_405.Outcometree.otype_unboxed = otype_unboxed; + Ast_405.Outcometree.otype_cstrs = otype_cstrs } + -> { - To.Outcometree.otype_name = otype_name; - To.Outcometree.otype_params = + Ast_404.Outcometree.otype_name = otype_name; + Ast_404.Outcometree.otype_params = (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) otype_params); - To.Outcometree.otype_type = - (copy_out_type otype_type); - To.Outcometree.otype_private = - (copy_From_Asttypes_private_flag otype_private); - To.Outcometree.otype_immediate = (copy_bool otype_immediate); - To.Outcometree.otype_unboxed = (copy_bool otype_unboxed); - To.Outcometree.otype_cstrs = + Ast_404.Outcometree.otype_type = (copy_out_type otype_type); + Ast_404.Outcometree.otype_private = (copy_private_flag otype_private); + Ast_404.Outcometree.otype_immediate = otype_immediate; + Ast_404.Outcometree.otype_unboxed = otype_unboxed; + Ast_404.Outcometree.otype_cstrs = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_type x0), - (copy_out_type x1))) otype_cstrs) + (fun x -> + let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1))) + otype_cstrs) } - and copy_out_module_type : - From.Outcometree.out_module_type -> To.Outcometree.out_module_type + Ast_405.Outcometree.out_module_type -> Ast_404.Outcometree.out_module_type = function - | From.Outcometree.Omty_abstract -> To.Outcometree.Omty_abstract - | From.Outcometree.Omty_functor (x0,x1,x2) -> - To.Outcometree.Omty_functor - (x0, (copy_option copy_out_module_type x1), - (copy_out_module_type x2)) - | From.Outcometree.Omty_ident x0 -> - To.Outcometree.Omty_ident (copy_out_ident x0) - | From.Outcometree.Omty_signature x0 -> - To.Outcometree.Omty_signature - (List.map copy_out_sig_item x0) - | From.Outcometree.Omty_alias x0 -> - To.Outcometree.Omty_alias (copy_out_ident x0) - + | Ast_405.Outcometree.Omty_abstract -> Ast_404.Outcometree.Omty_abstract + | Ast_405.Outcometree.Omty_functor (x0, x1, x2) -> + Ast_404.Outcometree.Omty_functor + (x0, (Option.map copy_out_module_type x1), (copy_out_module_type x2)) + | Ast_405.Outcometree.Omty_ident x0 -> + Ast_404.Outcometree.Omty_ident (copy_out_ident x0) + | Ast_405.Outcometree.Omty_signature x0 -> + Ast_404.Outcometree.Omty_signature (List.map copy_out_sig_item x0) + | Ast_405.Outcometree.Omty_alias x0 -> + Ast_404.Outcometree.Omty_alias (copy_out_ident x0) and copy_out_ext_status : - From.Outcometree.out_ext_status -> To.Outcometree.out_ext_status = + Ast_405.Outcometree.out_ext_status -> Ast_404.Outcometree.out_ext_status = function - | From.Outcometree.Oext_first -> To.Outcometree.Oext_first - | From.Outcometree.Oext_next -> To.Outcometree.Oext_next - | From.Outcometree.Oext_exception -> To.Outcometree.Oext_exception - + | Ast_405.Outcometree.Oext_first -> Ast_404.Outcometree.Oext_first + | Ast_405.Outcometree.Oext_next -> Ast_404.Outcometree.Oext_next + | Ast_405.Outcometree.Oext_exception -> Ast_404.Outcometree.Oext_exception and copy_out_extension_constructor : - From.Outcometree.out_extension_constructor -> - To.Outcometree.out_extension_constructor + Ast_405.Outcometree.out_extension_constructor -> + Ast_404.Outcometree.out_extension_constructor = fun - { From.Outcometree.oext_name = oext_name; - From.Outcometree.oext_type_name = oext_type_name; - From.Outcometree.oext_type_params = oext_type_params; - From.Outcometree.oext_args = oext_args; - From.Outcometree.oext_ret_type = oext_ret_type; - From.Outcometree.oext_private = oext_private } - -> + { Ast_405.Outcometree.oext_name = oext_name; + Ast_405.Outcometree.oext_type_name = oext_type_name; + Ast_405.Outcometree.oext_type_params = oext_type_params; + Ast_405.Outcometree.oext_args = oext_args; + Ast_405.Outcometree.oext_ret_type = oext_ret_type; + Ast_405.Outcometree.oext_private = oext_private } + -> { - To.Outcometree.oext_name = oext_name; - To.Outcometree.oext_type_name = oext_type_name; - To.Outcometree.oext_type_params = - (List.map (fun x -> x) oext_type_params); - To.Outcometree.oext_args = - (List.map copy_out_type oext_args); - To.Outcometree.oext_ret_type = - (copy_option copy_out_type oext_ret_type); - To.Outcometree.oext_private = - (copy_From_Asttypes_private_flag oext_private) + Ast_404.Outcometree.oext_name = oext_name; + Ast_404.Outcometree.oext_type_name = oext_type_name; + Ast_404.Outcometree.oext_type_params = + (List.map (fun x -> x) oext_type_params); + Ast_404.Outcometree.oext_args = (List.map copy_out_type oext_args); + Ast_404.Outcometree.oext_ret_type = + (Option.map copy_out_type oext_ret_type); + Ast_404.Outcometree.oext_private = (copy_private_flag oext_private) } - -and copy_From_Asttypes_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = +and copy_private_flag : + Ast_405.Asttypes.private_flag -> Ast_404.Asttypes.private_flag = function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - + | Ast_405.Asttypes.Private -> Ast_404.Asttypes.Private + | Ast_405.Asttypes.Public -> Ast_404.Asttypes.Public and copy_out_rec_status : - From.Outcometree.out_rec_status -> To.Outcometree.out_rec_status = + Ast_405.Outcometree.out_rec_status -> Ast_404.Outcometree.out_rec_status = function - | From.Outcometree.Orec_not -> To.Outcometree.Orec_not - | From.Outcometree.Orec_first -> To.Outcometree.Orec_first - | From.Outcometree.Orec_next -> To.Outcometree.Orec_next - + | Ast_405.Outcometree.Orec_not -> Ast_404.Outcometree.Orec_not + | Ast_405.Outcometree.Orec_first -> Ast_404.Outcometree.Orec_first + | Ast_405.Outcometree.Orec_next -> Ast_404.Outcometree.Orec_next and copy_out_class_type : - From.Outcometree.out_class_type -> To.Outcometree.out_class_type = - function - | From.Outcometree.Octy_constr (x0,x1) -> - To.Outcometree.Octy_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Octy_arrow (x0,x1,x2) -> - To.Outcometree.Octy_arrow - (x0, (copy_out_type x1), - (copy_out_class_type x2)) - | From.Outcometree.Octy_signature (x0,x1) -> - To.Outcometree.Octy_signature - ((copy_option copy_out_type x0), + Ast_405.Outcometree.out_class_type -> Ast_404.Outcometree.out_class_type = + function + | Ast_405.Outcometree.Octy_constr (x0, x1) -> + Ast_404.Outcometree.Octy_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_405.Outcometree.Octy_arrow (x0, x1, x2) -> + Ast_404.Outcometree.Octy_arrow + (x0, (copy_out_type x1), (copy_out_class_type x2)) + | Ast_405.Outcometree.Octy_signature (x0, x1) -> + Ast_404.Outcometree.Octy_signature + ((Option.map copy_out_type x0), (List.map copy_out_class_sig_item x1)) - and copy_out_class_sig_item : - From.Outcometree.out_class_sig_item -> - To.Outcometree.out_class_sig_item + Ast_405.Outcometree.out_class_sig_item -> + Ast_404.Outcometree.out_class_sig_item = function - | From.Outcometree.Ocsg_constraint (x0,x1) -> - To.Outcometree.Ocsg_constraint - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Ocsg_method (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_method - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - | From.Outcometree.Ocsg_value (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_value - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - + | Ast_405.Outcometree.Ocsg_constraint (x0, x1) -> + Ast_404.Outcometree.Ocsg_constraint + ((copy_out_type x0), (copy_out_type x1)) + | Ast_405.Outcometree.Ocsg_method (x0, x1, x2, x3) -> + Ast_404.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3)) + | Ast_405.Outcometree.Ocsg_value (x0, x1, x2, x3) -> + Ast_404.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3)) and copy_out_type : - From.Outcometree.out_type -> To.Outcometree.out_type = - function - | From.Outcometree.Otyp_abstract -> To.Outcometree.Otyp_abstract - | From.Outcometree.Otyp_open -> To.Outcometree.Otyp_open - | From.Outcometree.Otyp_alias (x0,x1) -> - To.Outcometree.Otyp_alias - ((copy_out_type x0), x1) - | From.Outcometree.Otyp_arrow (x0,x1,x2) -> - To.Outcometree.Otyp_arrow - (x0, (copy_out_type x1), - (copy_out_type x2)) - | From.Outcometree.Otyp_class (x0,x1,x2) -> - To.Outcometree.Otyp_class - ((copy_bool x0), (copy_out_ident x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_constr (x0,x1) -> - To.Outcometree.Otyp_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Otyp_manifest (x0,x1) -> - To.Outcometree.Otyp_manifest - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Otyp_object (x0,x1) -> - To.Outcometree.Otyp_object - ((List.map - (fun x -> - let (x0,x1) = x in - (x0, (copy_out_type x1))) x0), - (copy_option copy_bool x1)) - | From.Outcometree.Otyp_record x0 -> - To.Outcometree.Otyp_record + Ast_405.Outcometree.out_type -> Ast_404.Outcometree.out_type = + function + | Ast_405.Outcometree.Otyp_abstract -> Ast_404.Outcometree.Otyp_abstract + | Ast_405.Outcometree.Otyp_open -> Ast_404.Outcometree.Otyp_open + | Ast_405.Outcometree.Otyp_alias (x0, x1) -> + Ast_404.Outcometree.Otyp_alias ((copy_out_type x0), x1) + | Ast_405.Outcometree.Otyp_arrow (x0, x1, x2) -> + Ast_404.Outcometree.Otyp_arrow + (x0, (copy_out_type x1), (copy_out_type x2)) + | Ast_405.Outcometree.Otyp_class (x0, x1, x2) -> + Ast_404.Outcometree.Otyp_class + (x0, (copy_out_ident x1), (List.map copy_out_type x2)) + | Ast_405.Outcometree.Otyp_constr (x0, x1) -> + Ast_404.Outcometree.Otyp_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_405.Outcometree.Otyp_manifest (x0, x1) -> + Ast_404.Outcometree.Otyp_manifest + ((copy_out_type x0), (copy_out_type x1)) + | Ast_405.Outcometree.Otyp_object (x0, x1) -> + Ast_404.Outcometree.Otyp_object + ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0), + (Option.map (fun x -> x) x1)) + | Ast_405.Outcometree.Otyp_record x0 -> + Ast_404.Outcometree.Otyp_record (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), (copy_out_type x2))) - x0) - | From.Outcometree.Otyp_stuff x0 -> To.Outcometree.Otyp_stuff x0 - | From.Outcometree.Otyp_sum x0 -> - To.Outcometree.Otyp_sum + (fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0) + | Ast_405.Outcometree.Otyp_stuff x0 -> Ast_404.Outcometree.Otyp_stuff x0 + | Ast_405.Outcometree.Otyp_sum x0 -> + Ast_404.Outcometree.Otyp_sum (List.map - (fun x -> - let (x0,x1,x2) = x in + (fun x -> + let (x0, x1, x2) = x in (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) x0) - | From.Outcometree.Otyp_tuple x0 -> - To.Outcometree.Otyp_tuple - (List.map copy_out_type x0) - | From.Outcometree.Otyp_var (x0,x1) -> - To.Outcometree.Otyp_var ((copy_bool x0), x1) - | From.Outcometree.Otyp_variant (x0,x1,x2,x3) -> - To.Outcometree.Otyp_variant - ((copy_bool x0), (copy_out_variant x1), - (copy_bool x2), - (copy_option (fun x -> List.map (fun x -> x) x) x3)) - | From.Outcometree.Otyp_poly (x0,x1) -> - To.Outcometree.Otyp_poly - ((List.map (fun x -> x) x0), (copy_out_type x1)) - | From.Outcometree.Otyp_module (x0,x1,x2) -> - To.Outcometree.Otyp_module - (x0, (List.map (fun x -> x) x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_attribute (x0,x1) -> - To.Outcometree.Otyp_attribute - ((copy_out_type x0), - (copy_out_attribute x1)) - + (Option.map copy_out_type x2))) x0) + | Ast_405.Outcometree.Otyp_tuple x0 -> + Ast_404.Outcometree.Otyp_tuple (List.map copy_out_type x0) + | Ast_405.Outcometree.Otyp_var (x0, x1) -> + Ast_404.Outcometree.Otyp_var (x0, x1) + | Ast_405.Outcometree.Otyp_variant (x0, x1, x2, x3) -> + Ast_404.Outcometree.Otyp_variant + (x0, (copy_out_variant x1), x2, + (Option.map (fun x -> List.map (fun x -> x) x) x3)) + | Ast_405.Outcometree.Otyp_poly (x0, x1) -> + Ast_404.Outcometree.Otyp_poly + ((List.map (fun x -> x) x0), (copy_out_type x1)) + | Ast_405.Outcometree.Otyp_module (x0, x1, x2) -> + Ast_404.Outcometree.Otyp_module + (x0, (List.map (fun x -> x) x1), (List.map copy_out_type x2)) + | Ast_405.Outcometree.Otyp_attribute (x0, x1) -> + Ast_404.Outcometree.Otyp_attribute + ((copy_out_type x0), (copy_out_attribute x1)) and copy_out_attribute : - From.Outcometree.out_attribute -> To.Outcometree.out_attribute = - fun { From.Outcometree.oattr_name = oattr_name } -> - { To.Outcometree.oattr_name = oattr_name } - + Ast_405.Outcometree.out_attribute -> Ast_404.Outcometree.out_attribute = + fun { Ast_405.Outcometree.oattr_name = oattr_name } -> + { Ast_404.Outcometree.oattr_name = oattr_name } and copy_out_variant : - From.Outcometree.out_variant -> To.Outcometree.out_variant = + Ast_405.Outcometree.out_variant -> Ast_404.Outcometree.out_variant = function - | From.Outcometree.Ovar_fields x0 -> - To.Outcometree.Ovar_fields + | Ast_405.Outcometree.Ovar_fields x0 -> + Ast_404.Outcometree.Ovar_fields (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), - (List.map copy_out_type x2))) x0) + (fun x -> + let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2))) + x0) | From.Outcometree.Ovar_typ (From.Outcometree.Otyp_constr (id,tyl)) -> To.Outcometree.Ovar_name (copy_out_ident id, List.map copy_out_type tyl) | From.Outcometree.Ovar_typ x0 -> To.Outcometree.Ovar_name (To.Outcometree.Oide_ident "", [copy_out_type x0]) - and copy_out_value : - From.Outcometree.out_value -> To.Outcometree.out_value = - function - | From.Outcometree.Oval_array x0 -> - To.Outcometree.Oval_array - (List.map copy_out_value x0) - | From.Outcometree.Oval_char x0 -> To.Outcometree.Oval_char x0 - | From.Outcometree.Oval_constr (x0,x1) -> - To.Outcometree.Oval_constr - ((copy_out_ident x0), - (List.map copy_out_value x1)) - | From.Outcometree.Oval_ellipsis -> To.Outcometree.Oval_ellipsis - | From.Outcometree.Oval_float x0 -> - To.Outcometree.Oval_float (copy_float x0) - | From.Outcometree.Oval_int x0 -> To.Outcometree.Oval_int x0 - | From.Outcometree.Oval_int32 x0 -> To.Outcometree.Oval_int32 x0 - | From.Outcometree.Oval_int64 x0 -> To.Outcometree.Oval_int64 x0 - | From.Outcometree.Oval_nativeint x0 -> - To.Outcometree.Oval_nativeint x0 - | From.Outcometree.Oval_list x0 -> - To.Outcometree.Oval_list - (List.map copy_out_value x0) - | From.Outcometree.Oval_printer x0 -> - To.Outcometree.Oval_printer x0 - | From.Outcometree.Oval_record x0 -> - To.Outcometree.Oval_record + Ast_405.Outcometree.out_value -> Ast_404.Outcometree.out_value = + function + | Ast_405.Outcometree.Oval_array x0 -> + Ast_404.Outcometree.Oval_array (List.map copy_out_value x0) + | Ast_405.Outcometree.Oval_char x0 -> Ast_404.Outcometree.Oval_char x0 + | Ast_405.Outcometree.Oval_constr (x0, x1) -> + Ast_404.Outcometree.Oval_constr + ((copy_out_ident x0), (List.map copy_out_value x1)) + | Ast_405.Outcometree.Oval_ellipsis -> Ast_404.Outcometree.Oval_ellipsis + | Ast_405.Outcometree.Oval_float x0 -> Ast_404.Outcometree.Oval_float x0 + | Ast_405.Outcometree.Oval_int x0 -> Ast_404.Outcometree.Oval_int x0 + | Ast_405.Outcometree.Oval_int32 x0 -> Ast_404.Outcometree.Oval_int32 x0 + | Ast_405.Outcometree.Oval_int64 x0 -> Ast_404.Outcometree.Oval_int64 x0 + | Ast_405.Outcometree.Oval_nativeint x0 -> + Ast_404.Outcometree.Oval_nativeint x0 + | Ast_405.Outcometree.Oval_list x0 -> + Ast_404.Outcometree.Oval_list (List.map copy_out_value x0) + | Ast_405.Outcometree.Oval_printer x0 -> + Ast_404.Outcometree.Oval_printer x0 + | Ast_405.Outcometree.Oval_record x0 -> + Ast_404.Outcometree.Oval_record (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_ident x0), - (copy_out_value x1))) x0) - | From.Outcometree.Oval_string x0 -> To.Outcometree.Oval_string x0 - | From.Outcometree.Oval_stuff x0 -> To.Outcometree.Oval_stuff x0 - | From.Outcometree.Oval_tuple x0 -> - To.Outcometree.Oval_tuple - (List.map copy_out_value x0) - | From.Outcometree.Oval_variant (x0,x1) -> - To.Outcometree.Oval_variant - (x0, (copy_option copy_out_value x1)) - -and copy_float : float -> float = fun x -> x - + (fun x -> + let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1))) + x0) + | Ast_405.Outcometree.Oval_string x0 -> Ast_404.Outcometree.Oval_string x0 + | Ast_405.Outcometree.Oval_stuff x0 -> Ast_404.Outcometree.Oval_stuff x0 + | Ast_405.Outcometree.Oval_tuple x0 -> + Ast_404.Outcometree.Oval_tuple (List.map copy_out_value x0) + | Ast_405.Outcometree.Oval_variant (x0, x1) -> + Ast_404.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1)) and copy_out_ident : - From.Outcometree.out_ident -> To.Outcometree.out_ident = - function - | From.Outcometree.Oide_apply (x0,x1) -> - To.Outcometree.Oide_apply - ((copy_out_ident x0), - (copy_out_ident x1)) - | From.Outcometree.Oide_dot (x0,x1) -> - To.Outcometree.Oide_dot - ((copy_out_ident x0), x1) - | From.Outcometree.Oide_ident x0 -> To.Outcometree.Oide_ident x0 - -let rec copy_toplevel_phrase : - From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = - function - | From.Parsetree.Ptop_def x0 -> - To.Parsetree.Ptop_def (copy_structure x0) - | From.Parsetree.Ptop_dir (x0,x1) -> - To.Parsetree.Ptop_dir - (x0, (copy_directive_argument x1)) - -and copy_directive_argument : - From.Parsetree.directive_argument -> To.Parsetree.directive_argument = - function - | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none - | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 - | From.Parsetree.Pdir_int (x0,x1) -> - To.Parsetree.Pdir_int (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pdir_ident x0 -> - To.Parsetree.Pdir_ident (copy_longident x0) - | From.Parsetree.Pdir_bool x0 -> - To.Parsetree.Pdir_bool (copy_bool x0) - -let copy_out_type_extension : - From.Outcometree.out_type_extension -> To.Outcometree.out_type_extension = - fun - { From.Outcometree.otyext_name = otyext_name; - From.Outcometree.otyext_params = otyext_params; - From.Outcometree.otyext_constructors = otyext_constructors; - From.Outcometree.otyext_private = otyext_private } - -> - { - To.Outcometree.otyext_name = otyext_name; - To.Outcometree.otyext_params = - (List.map (fun x -> x) otyext_params); - To.Outcometree.otyext_constructors = - (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) - otyext_constructors); - To.Outcometree.otyext_private = - (copy_private_flag otyext_private) - } - -let copy_cases x = List.map copy_case x -let copy_pat = copy_pattern -let copy_expr = copy_expression -let copy_typ = copy_core_type + Ast_405.Outcometree.out_ident -> Ast_404.Outcometree.out_ident = + function + | Ast_405.Outcometree.Oide_apply (x0, x1) -> + Ast_404.Outcometree.Oide_apply + ((copy_out_ident x0), (copy_out_ident x1)) + | Ast_405.Outcometree.Oide_dot (x0, x1) -> + Ast_404.Outcometree.Oide_dot ((copy_out_ident x0), x1) + | Ast_405.Outcometree.Oide_ident x0 -> Ast_404.Outcometree.Oide_ident x0 diff --git a/src/vendored-omp/src/migrate_parsetree_405_406.ml b/src/vendored-omp/src/migrate_parsetree_405_406.ml index c3e84c754..d312d78d2 100644 --- a/src/vendored-omp/src/migrate_parsetree_405_406.ml +++ b/src/vendored-omp/src/migrate_parsetree_405_406.ml @@ -15,116 +15,3 @@ include Migrate_parsetree_405_406_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - (*$*) - } as mapper) -> - let module R = Migrate_parsetree_406_405_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_405_406_migrate.ml b/src/vendored-omp/src/migrate_parsetree_405_406_migrate.ml index c795a1d5c..5429bac20 100644 --- a/src/vendored-omp/src/migrate_parsetree_405_406_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_405_406_migrate.ml @@ -1,1714 +1,300 @@ -(**************************************************************************) -(* *) -(* OCaml Migrate Parsetree *) -(* *) -(* Frédéric Bour *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2017 Institut National de Recherche en Informatique et *) -(* en Automatique (INRIA). *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - +open Stdlib0 module From = Ast_405 module To = Ast_406 - -let rec copy_expression : - From.Parsetree.expression -> To.Parsetree.expression = - fun - { From.Parsetree.pexp_desc = pexp_desc; - From.Parsetree.pexp_loc = pexp_loc; - From.Parsetree.pexp_attributes = pexp_attributes } - -> - { - To.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - To.Parsetree.pexp_loc = (copy_location pexp_loc); - To.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } - -and copy_expression_desc : - From.Parsetree.expression_desc -> To.Parsetree.expression_desc = - function - | From.Parsetree.Pexp_ident x0 -> - To.Parsetree.Pexp_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_constant x0 -> - To.Parsetree.Pexp_constant (copy_constant x0) - | From.Parsetree.Pexp_let (x0,x1,x2) -> - To.Parsetree.Pexp_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_expression x2)) - | From.Parsetree.Pexp_function x0 -> - To.Parsetree.Pexp_function - (List.map copy_case x0) - | From.Parsetree.Pexp_fun (x0,x1,x2,x3) -> - To.Parsetree.Pexp_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_expression x3)) - | From.Parsetree.Pexp_apply (x0,x1) -> - To.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pexp_match (x0,x1) -> - To.Parsetree.Pexp_match - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_try (x0,x1) -> - To.Parsetree.Pexp_try - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_tuple x0 -> - To.Parsetree.Pexp_tuple - (List.map copy_expression x0) - | From.Parsetree.Pexp_construct (x0,x1) -> - To.Parsetree.Pexp_construct - ((copy_loc copy_longident x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_variant (x0,x1) -> - To.Parsetree.Pexp_variant - ((copy_label x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_record (x0,x1) -> - To.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_expression x1))) x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_field (x0,x1) -> - To.Parsetree.Pexp_field - ((copy_expression x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pexp_setfield (x0,x1,x2) -> - To.Parsetree.Pexp_setfield - ((copy_expression x0), - (copy_loc copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_array x0 -> - To.Parsetree.Pexp_array - (List.map copy_expression x0) - | From.Parsetree.Pexp_ifthenelse (x0,x1,x2) -> - To.Parsetree.Pexp_ifthenelse - ((copy_expression x0), - (copy_expression x1), - (copy_option copy_expression x2)) - | From.Parsetree.Pexp_sequence (x0,x1) -> - To.Parsetree.Pexp_sequence - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_while (x0,x1) -> - To.Parsetree.Pexp_while - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_for (x0,x1,x2,x3,x4) -> - To.Parsetree.Pexp_for - ((copy_pattern x0), - (copy_expression x1), - (copy_expression x2), - (copy_direction_flag x3), - (copy_expression x4)) - | From.Parsetree.Pexp_constraint (x0,x1) -> - To.Parsetree.Pexp_constraint - ((copy_expression x0), - (copy_core_type x1)) - | From.Parsetree.Pexp_coerce (x0,x1,x2) -> - To.Parsetree.Pexp_coerce - ((copy_expression x0), - (copy_option copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Pexp_send (x0,x1) -> - To.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc (fun x -> x) x1)) - | From.Parsetree.Pexp_new x0 -> - To.Parsetree.Pexp_new - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_setinstvar (x0,x1) -> - To.Parsetree.Pexp_setinstvar - ((copy_loc (fun x -> x) x0), - (copy_expression x1)) - | From.Parsetree.Pexp_override x0 -> - To.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_expression x1))) x0) - | From.Parsetree.Pexp_letmodule (x0,x1,x2) -> - To.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> x) x0), - (copy_module_expr x1), - (copy_expression x2)) - | From.Parsetree.Pexp_letexception (x0,x1) -> - To.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), - (copy_expression x1)) - | From.Parsetree.Pexp_assert x0 -> - To.Parsetree.Pexp_assert (copy_expression x0) - | From.Parsetree.Pexp_lazy x0 -> - To.Parsetree.Pexp_lazy (copy_expression x0) - | From.Parsetree.Pexp_poly (x0,x1) -> - To.Parsetree.Pexp_poly - ((copy_expression x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pexp_object x0 -> - To.Parsetree.Pexp_object - (copy_class_structure x0) - | From.Parsetree.Pexp_newtype (x0,x1) -> - To.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | From.Parsetree.Pexp_pack x0 -> - To.Parsetree.Pexp_pack (copy_module_expr x0) - | From.Parsetree.Pexp_open (x0,x1,x2) -> - To.Parsetree.Pexp_open - ((copy_override_flag x0), - (copy_loc copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_extension x0 -> - To.Parsetree.Pexp_extension (copy_extension x0) - | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable - -and copy_direction_flag : - From.Asttypes.direction_flag -> To.Asttypes.direction_flag = - function - | From.Asttypes.Upto -> To.Asttypes.Upto - | From.Asttypes.Downto -> To.Asttypes.Downto - -and copy_case : - From.Parsetree.case -> To.Parsetree.case = - fun - { From.Parsetree.pc_lhs = pc_lhs; - From.Parsetree.pc_guard = pc_guard; - From.Parsetree.pc_rhs = pc_rhs } - -> - { - To.Parsetree.pc_lhs = (copy_pattern pc_lhs); - To.Parsetree.pc_guard = - (copy_option copy_expression pc_guard); - To.Parsetree.pc_rhs = (copy_expression pc_rhs) - } - -and copy_value_binding : - From.Parsetree.value_binding -> To.Parsetree.value_binding = - fun - { From.Parsetree.pvb_pat = pvb_pat; - From.Parsetree.pvb_expr = pvb_expr; - From.Parsetree.pvb_attributes = pvb_attributes; - From.Parsetree.pvb_loc = pvb_loc } - -> - { - To.Parsetree.pvb_pat = (copy_pattern pvb_pat); - To.Parsetree.pvb_expr = - (copy_expression pvb_expr); - To.Parsetree.pvb_attributes = - (copy_attributes pvb_attributes); - To.Parsetree.pvb_loc = (copy_location pvb_loc) - } - -and copy_pattern : - From.Parsetree.pattern -> To.Parsetree.pattern = - fun - { From.Parsetree.ppat_desc = ppat_desc; - From.Parsetree.ppat_loc = ppat_loc; - From.Parsetree.ppat_attributes = ppat_attributes } - -> - { - To.Parsetree.ppat_desc = - (copy_pattern_desc ppat_desc); - To.Parsetree.ppat_loc = (copy_location ppat_loc); - To.Parsetree.ppat_attributes = - (copy_attributes ppat_attributes) - } - -and copy_pattern_desc : - From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc = - function - | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any - | From.Parsetree.Ppat_var x0 -> - To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_alias (x0,x1) -> - To.Parsetree.Ppat_alias - ((copy_pattern x0), - (copy_loc (fun x -> x) x1)) - | From.Parsetree.Ppat_constant x0 -> - To.Parsetree.Ppat_constant (copy_constant x0) - | From.Parsetree.Ppat_interval (x0,x1) -> - To.Parsetree.Ppat_interval - ((copy_constant x0), - (copy_constant x1)) - | From.Parsetree.Ppat_tuple x0 -> - To.Parsetree.Ppat_tuple - (List.map copy_pattern x0) - | From.Parsetree.Ppat_construct (x0,x1) -> - To.Parsetree.Ppat_construct - ((copy_loc copy_longident x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_variant (x0,x1) -> - To.Parsetree.Ppat_variant - ((copy_label x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_record (x0,x1) -> - To.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ppat_array x0 -> - To.Parsetree.Ppat_array - (List.map copy_pattern x0) - | From.Parsetree.Ppat_or (x0,x1) -> - To.Parsetree.Ppat_or - ((copy_pattern x0), - (copy_pattern x1)) - | From.Parsetree.Ppat_constraint (x0,x1) -> - To.Parsetree.Ppat_constraint - ((copy_pattern x0), - (copy_core_type x1)) - | From.Parsetree.Ppat_type x0 -> - To.Parsetree.Ppat_type - (copy_loc copy_longident x0) - | From.Parsetree.Ppat_lazy x0 -> - To.Parsetree.Ppat_lazy (copy_pattern x0) - | From.Parsetree.Ppat_unpack x0 -> - To.Parsetree.Ppat_unpack - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_exception x0 -> - To.Parsetree.Ppat_exception (copy_pattern x0) - | From.Parsetree.Ppat_extension x0 -> - To.Parsetree.Ppat_extension (copy_extension x0) - | From.Parsetree.Ppat_open (x0,x1) -> - To.Parsetree.Ppat_open - ((copy_loc copy_longident x0), - (copy_pattern x1)) - -and copy_core_type : - From.Parsetree.core_type -> To.Parsetree.core_type = - fun - { From.Parsetree.ptyp_desc = ptyp_desc; - From.Parsetree.ptyp_loc = ptyp_loc; - From.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - To.Parsetree.ptyp_desc = - (copy_core_type_desc ptyp_desc); - To.Parsetree.ptyp_loc = (copy_location ptyp_loc); - To.Parsetree.ptyp_attributes = - (copy_attributes ptyp_attributes) - } - -and copy_core_type_desc : - From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = - function - | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any - | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 - | From.Parsetree.Ptyp_arrow (x0,x1,x2) -> - To.Parsetree.Ptyp_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Ptyp_tuple x0 -> - To.Parsetree.Ptyp_tuple - (List.map copy_core_type x0) - | From.Parsetree.Ptyp_constr (x0,x1) -> - To.Parsetree.Ptyp_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_object (x0,x1) -> - To.Parsetree.Ptyp_object - ((List.map - (fun x -> - let (x0,x1,x2) = x in - To.Parsetree.Otag - (copy_loc (fun x -> x) x0, (copy_attributes x1), - (copy_core_type x2))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ptyp_class (x0,x1) -> - To.Parsetree.Ptyp_class - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_alias (x0,x1) -> - To.Parsetree.Ptyp_alias - ((copy_core_type x0), x1) - | From.Parsetree.Ptyp_variant (x0,x1,x2) -> - To.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), - (copy_closed_flag x1), - (copy_option (fun x -> List.map copy_label x) x2)) - | From.Parsetree.Ptyp_poly (x0,x1) -> - To.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), (copy_core_type x1)) - | From.Parsetree.Ptyp_package x0 -> - To.Parsetree.Ptyp_package (copy_package_type x0) - | From.Parsetree.Ptyp_extension x0 -> - To.Parsetree.Ptyp_extension (copy_extension x0) - -and copy_package_type : - From.Parsetree.package_type -> To.Parsetree.package_type = - fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_core_type x1))) x1)) - -and copy_row_field : - From.Parsetree.row_field -> To.Parsetree.row_field = - function - | From.Parsetree.Rtag (x0,x1,x2,x3) -> - To.Parsetree.Rtag - (({ txt = copy_label x0; loc = Location.none; }), - (copy_attributes x1), (copy_bool x2), - (List.map copy_core_type x3)) - | From.Parsetree.Rinherit x0 -> - To.Parsetree.Rinherit (copy_core_type x0) - -and copy_attributes : - From.Parsetree.attributes -> To.Parsetree.attributes = - fun x -> List.map copy_attribute x - -and copy_attribute : - From.Parsetree.attribute -> To.Parsetree.attribute = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_payload : - From.Parsetree.payload -> To.Parsetree.payload = - function - | From.Parsetree.PStr x0 -> - To.Parsetree.PStr (copy_structure x0) - | From.Parsetree.PSig x0 -> - To.Parsetree.PSig (copy_signature x0) - | From.Parsetree.PTyp x0 -> - To.Parsetree.PTyp (copy_core_type x0) - | From.Parsetree.PPat (x0,x1) -> - To.Parsetree.PPat - ((copy_pattern x0), - (copy_option copy_expression x1)) - -and copy_structure : - From.Parsetree.structure -> To.Parsetree.structure = - fun x -> List.map copy_structure_item x - -and copy_structure_item : - From.Parsetree.structure_item -> To.Parsetree.structure_item = - fun - { From.Parsetree.pstr_desc = pstr_desc; - From.Parsetree.pstr_loc = pstr_loc } - -> - { - To.Parsetree.pstr_desc = - (copy_structure_item_desc pstr_desc); - To.Parsetree.pstr_loc = (copy_location pstr_loc) - } - -and copy_structure_item_desc : - From.Parsetree.structure_item_desc -> - To.Parsetree.structure_item_desc - = - function - | From.Parsetree.Pstr_eval (x0,x1) -> - To.Parsetree.Pstr_eval - ((copy_expression x0), - (copy_attributes x1)) - | From.Parsetree.Pstr_value (x0,x1) -> - To.Parsetree.Pstr_value - ((copy_rec_flag x0), - (List.map copy_value_binding x1)) - | From.Parsetree.Pstr_primitive x0 -> - To.Parsetree.Pstr_primitive - (copy_value_description x0) - | From.Parsetree.Pstr_type (x0,x1) -> - To.Parsetree.Pstr_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Pstr_typext x0 -> - To.Parsetree.Pstr_typext - (copy_type_extension x0) - | From.Parsetree.Pstr_exception x0 -> - To.Parsetree.Pstr_exception - (copy_extension_constructor x0) - | From.Parsetree.Pstr_module x0 -> - To.Parsetree.Pstr_module - (copy_module_binding x0) - | From.Parsetree.Pstr_recmodule x0 -> - To.Parsetree.Pstr_recmodule - (List.map copy_module_binding x0) - | From.Parsetree.Pstr_modtype x0 -> - To.Parsetree.Pstr_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Pstr_open x0 -> - To.Parsetree.Pstr_open - (copy_open_description x0) - | From.Parsetree.Pstr_class x0 -> - To.Parsetree.Pstr_class - (List.map copy_class_declaration x0) - | From.Parsetree.Pstr_class_type x0 -> - To.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Pstr_include x0 -> - To.Parsetree.Pstr_include - (copy_include_declaration x0) - | From.Parsetree.Pstr_attribute x0 -> - To.Parsetree.Pstr_attribute (copy_attribute x0) - | From.Parsetree.Pstr_extension (x0,x1) -> - To.Parsetree.Pstr_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_include_declaration : - From.Parsetree.include_declaration -> - To.Parsetree.include_declaration - = - fun x -> - copy_include_infos copy_module_expr x - -and copy_class_declaration : - From.Parsetree.class_declaration -> To.Parsetree.class_declaration - = - fun x -> - copy_class_infos copy_class_expr x - -and copy_class_expr : - From.Parsetree.class_expr -> To.Parsetree.class_expr = - fun - { From.Parsetree.pcl_desc = pcl_desc; - From.Parsetree.pcl_loc = pcl_loc; - From.Parsetree.pcl_attributes = pcl_attributes } - -> - { - To.Parsetree.pcl_desc = - (copy_class_expr_desc pcl_desc); - To.Parsetree.pcl_loc = (copy_location pcl_loc); - To.Parsetree.pcl_attributes = - (copy_attributes pcl_attributes) - } - -and copy_class_expr_desc : - From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = - function - | From.Parsetree.Pcl_constr (x0,x1) -> - To.Parsetree.Pcl_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcl_structure x0 -> - To.Parsetree.Pcl_structure - (copy_class_structure x0) - | From.Parsetree.Pcl_fun (x0,x1,x2,x3) -> - To.Parsetree.Pcl_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_class_expr x3)) - | From.Parsetree.Pcl_apply (x0,x1) -> - To.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pcl_let (x0,x1,x2) -> - To.Parsetree.Pcl_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_class_expr x2)) - | From.Parsetree.Pcl_constraint (x0,x1) -> - To.Parsetree.Pcl_constraint - ((copy_class_expr x0), - (copy_class_type x1)) - | From.Parsetree.Pcl_extension x0 -> - To.Parsetree.Pcl_extension (copy_extension x0) - -and copy_class_structure : - From.Parsetree.class_structure -> To.Parsetree.class_structure = - fun - { From.Parsetree.pcstr_self = pcstr_self; - From.Parsetree.pcstr_fields = pcstr_fields } - -> - { - To.Parsetree.pcstr_self = - (copy_pattern pcstr_self); - To.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } - -and copy_class_field : - From.Parsetree.class_field -> To.Parsetree.class_field = - fun - { From.Parsetree.pcf_desc = pcf_desc; - From.Parsetree.pcf_loc = pcf_loc; - From.Parsetree.pcf_attributes = pcf_attributes } - -> - { - To.Parsetree.pcf_desc = - (copy_class_field_desc pcf_desc); - To.Parsetree.pcf_loc = (copy_location pcf_loc); - To.Parsetree.pcf_attributes = - (copy_attributes pcf_attributes) - } - -and copy_class_field_desc : - From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = - function - | From.Parsetree.Pcf_inherit (x0,x1,x2) -> - To.Parsetree.Pcf_inherit - ((copy_override_flag x0), - (copy_class_expr x1), - (copy_option (copy_loc (fun x -> x)) x2)) - | From.Parsetree.Pcf_val x0 -> - To.Parsetree.Pcf_val - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_method x0 -> - To.Parsetree.Pcf_method - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_private_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_constraint x0 -> - To.Parsetree.Pcf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pcf_initializer x0 -> - To.Parsetree.Pcf_initializer - (copy_expression x0) - | From.Parsetree.Pcf_attribute x0 -> - To.Parsetree.Pcf_attribute (copy_attribute x0) - | From.Parsetree.Pcf_extension x0 -> - To.Parsetree.Pcf_extension (copy_extension x0) - -and copy_class_field_kind : - From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = - function - | From.Parsetree.Cfk_virtual x0 -> - To.Parsetree.Cfk_virtual (copy_core_type x0) - | From.Parsetree.Cfk_concrete (x0,x1) -> - To.Parsetree.Cfk_concrete - ((copy_override_flag x0), - (copy_expression x1)) - -and copy_module_binding : - From.Parsetree.module_binding -> To.Parsetree.module_binding = - fun - { From.Parsetree.pmb_name = pmb_name; - From.Parsetree.pmb_expr = pmb_expr; - From.Parsetree.pmb_attributes = pmb_attributes; - From.Parsetree.pmb_loc = pmb_loc } - -> - { - To.Parsetree.pmb_name = - (copy_loc (fun x -> x) pmb_name); - To.Parsetree.pmb_expr = - (copy_module_expr pmb_expr); - To.Parsetree.pmb_attributes = - (copy_attributes pmb_attributes); - To.Parsetree.pmb_loc = (copy_location pmb_loc) - } - -and copy_module_expr : - From.Parsetree.module_expr -> To.Parsetree.module_expr = - fun - { From.Parsetree.pmod_desc = pmod_desc; - From.Parsetree.pmod_loc = pmod_loc; - From.Parsetree.pmod_attributes = pmod_attributes } - -> - { - To.Parsetree.pmod_desc = - (copy_module_expr_desc pmod_desc); - To.Parsetree.pmod_loc = (copy_location pmod_loc); - To.Parsetree.pmod_attributes = - (copy_attributes pmod_attributes) - } - -and copy_module_expr_desc : - From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = - function - | From.Parsetree.Pmod_ident x0 -> - To.Parsetree.Pmod_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmod_structure x0 -> - To.Parsetree.Pmod_structure (copy_structure x0) - | From.Parsetree.Pmod_functor (x0,x1,x2) -> - To.Parsetree.Pmod_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_expr x2)) - | From.Parsetree.Pmod_apply (x0,x1) -> - To.Parsetree.Pmod_apply - ((copy_module_expr x0), - (copy_module_expr x1)) - | From.Parsetree.Pmod_constraint (x0,x1) -> - To.Parsetree.Pmod_constraint - ((copy_module_expr x0), - (copy_module_type x1)) - | From.Parsetree.Pmod_unpack x0 -> - To.Parsetree.Pmod_unpack (copy_expression x0) - | From.Parsetree.Pmod_extension x0 -> - To.Parsetree.Pmod_extension (copy_extension x0) - -and copy_module_type : - From.Parsetree.module_type -> To.Parsetree.module_type = - fun - { From.Parsetree.pmty_desc = pmty_desc; - From.Parsetree.pmty_loc = pmty_loc; - From.Parsetree.pmty_attributes = pmty_attributes } - -> - { - To.Parsetree.pmty_desc = - (copy_module_type_desc pmty_desc); - To.Parsetree.pmty_loc = (copy_location pmty_loc); - To.Parsetree.pmty_attributes = - (copy_attributes pmty_attributes) - } - -and copy_module_type_desc : - From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = - function - | From.Parsetree.Pmty_ident x0 -> - To.Parsetree.Pmty_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmty_signature x0 -> - To.Parsetree.Pmty_signature (copy_signature x0) - | From.Parsetree.Pmty_functor (x0,x1,x2) -> - To.Parsetree.Pmty_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_type x2)) - | From.Parsetree.Pmty_with (x0,x1) -> - To.Parsetree.Pmty_with - ((copy_module_type x0), - (List.map copy_with_constraint x1)) - | From.Parsetree.Pmty_typeof x0 -> - To.Parsetree.Pmty_typeof (copy_module_expr x0) - | From.Parsetree.Pmty_extension x0 -> - To.Parsetree.Pmty_extension (copy_extension x0) - | From.Parsetree.Pmty_alias x0 -> - To.Parsetree.Pmty_alias - (copy_loc copy_longident x0) - -and copy_with_constraint : - From.Parsetree.with_constraint -> To.Parsetree.with_constraint = - function - | From.Parsetree.Pwith_type (x0,x1) -> - To.Parsetree.Pwith_type - ((copy_loc copy_longident x0), - (copy_type_declaration x1)) - | From.Parsetree.Pwith_module (x0,x1) -> - To.Parsetree.Pwith_module - ((copy_loc copy_longident x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pwith_typesubst x0 -> - To.Parsetree.Pwith_typesubst - (copy_loc (fun x -> Longident.Lident x) x0.From.Parsetree.ptype_name, - copy_type_declaration x0) - | From.Parsetree.Pwith_modsubst (x0,x1) -> - To.Parsetree.Pwith_modsubst - (copy_loc (fun x -> Longident.Lident x) x0, - copy_loc copy_longident x1) - -and copy_signature : - From.Parsetree.signature -> To.Parsetree.signature = - fun x -> List.map copy_signature_item x - -and copy_signature_item : - From.Parsetree.signature_item -> To.Parsetree.signature_item = - fun - { From.Parsetree.psig_desc = psig_desc; - From.Parsetree.psig_loc = psig_loc } - -> - { - To.Parsetree.psig_desc = - (copy_signature_item_desc psig_desc); - To.Parsetree.psig_loc = (copy_location psig_loc) - } - -and copy_signature_item_desc : - From.Parsetree.signature_item_desc -> - To.Parsetree.signature_item_desc - = - function - | From.Parsetree.Psig_value x0 -> - To.Parsetree.Psig_value - (copy_value_description x0) - | From.Parsetree.Psig_type (x0,x1) -> - To.Parsetree.Psig_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Psig_typext x0 -> - To.Parsetree.Psig_typext - (copy_type_extension x0) - | From.Parsetree.Psig_exception x0 -> - To.Parsetree.Psig_exception - (copy_extension_constructor x0) - | From.Parsetree.Psig_module x0 -> - To.Parsetree.Psig_module - (copy_module_declaration x0) - | From.Parsetree.Psig_recmodule x0 -> - To.Parsetree.Psig_recmodule - (List.map copy_module_declaration x0) - | From.Parsetree.Psig_modtype x0 -> - To.Parsetree.Psig_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Psig_open x0 -> - To.Parsetree.Psig_open - (copy_open_description x0) - | From.Parsetree.Psig_include x0 -> - To.Parsetree.Psig_include - (copy_include_description x0) - | From.Parsetree.Psig_class x0 -> - To.Parsetree.Psig_class - (List.map copy_class_description x0) - | From.Parsetree.Psig_class_type x0 -> - To.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Psig_attribute x0 -> - To.Parsetree.Psig_attribute (copy_attribute x0) - | From.Parsetree.Psig_extension (x0,x1) -> - To.Parsetree.Psig_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_class_type_declaration : - From.Parsetree.class_type_declaration -> - To.Parsetree.class_type_declaration - = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_description : - From.Parsetree.class_description -> To.Parsetree.class_description - = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_type : - From.Parsetree.class_type -> To.Parsetree.class_type = - fun - { From.Parsetree.pcty_desc = pcty_desc; - From.Parsetree.pcty_loc = pcty_loc; - From.Parsetree.pcty_attributes = pcty_attributes } - -> - { - To.Parsetree.pcty_desc = - (copy_class_type_desc pcty_desc); - To.Parsetree.pcty_loc = (copy_location pcty_loc); - To.Parsetree.pcty_attributes = - (copy_attributes pcty_attributes) - } - -and copy_class_type_desc : - From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = - function - | From.Parsetree.Pcty_constr (x0,x1) -> - To.Parsetree.Pcty_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcty_signature x0 -> - To.Parsetree.Pcty_signature - (copy_class_signature x0) - | From.Parsetree.Pcty_arrow (x0,x1,x2) -> - To.Parsetree.Pcty_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_class_type x2)) - | From.Parsetree.Pcty_extension x0 -> - To.Parsetree.Pcty_extension (copy_extension x0) - -and copy_class_signature : - From.Parsetree.class_signature -> To.Parsetree.class_signature = - fun - { From.Parsetree.pcsig_self = pcsig_self; - From.Parsetree.pcsig_fields = pcsig_fields } - -> - { - To.Parsetree.pcsig_self = - (copy_core_type pcsig_self); - To.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } - -and copy_class_type_field : - From.Parsetree.class_type_field -> To.Parsetree.class_type_field = - fun - { From.Parsetree.pctf_desc = pctf_desc; - From.Parsetree.pctf_loc = pctf_loc; - From.Parsetree.pctf_attributes = pctf_attributes } - -> - { - To.Parsetree.pctf_desc = - (copy_class_type_field_desc pctf_desc); - To.Parsetree.pctf_loc = (copy_location pctf_loc); - To.Parsetree.pctf_attributes = - (copy_attributes pctf_attributes) - } - -and copy_class_type_field_desc : - From.Parsetree.class_type_field_desc -> - To.Parsetree.class_type_field_desc - = - function - | From.Parsetree.Pctf_inherit x0 -> - To.Parsetree.Pctf_inherit (copy_class_type x0) - | From.Parsetree.Pctf_val x0 -> - To.Parsetree.Pctf_val - (let (x0,x1,x2,x3) = x0 in - (copy_loc (fun x -> x) x0, (copy_mutable_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_method x0 -> - To.Parsetree.Pctf_method - (let (x0,x1,x2,x3) = x0 in - (copy_loc (fun x -> x) x0, (copy_private_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_constraint x0 -> - To.Parsetree.Pctf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pctf_attribute x0 -> - To.Parsetree.Pctf_attribute (copy_attribute x0) - | From.Parsetree.Pctf_extension x0 -> - To.Parsetree.Pctf_extension (copy_extension x0) - -and copy_extension : - From.Parsetree.extension -> To.Parsetree.extension = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.class_infos -> 'g0 To.Parsetree.class_infos - = - fun f0 -> - fun - { From.Parsetree.pci_virt = pci_virt; - From.Parsetree.pci_params = pci_params; - From.Parsetree.pci_name = pci_name; - From.Parsetree.pci_expr = pci_expr; - From.Parsetree.pci_loc = pci_loc; - From.Parsetree.pci_attributes = pci_attributes } - -> - { - To.Parsetree.pci_virt = - (copy_virtual_flag pci_virt); - To.Parsetree.pci_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) pci_params); - To.Parsetree.pci_name = - (copy_loc (fun x -> x) pci_name); - To.Parsetree.pci_expr = (f0 pci_expr); - To.Parsetree.pci_loc = (copy_location pci_loc); - To.Parsetree.pci_attributes = - (copy_attributes pci_attributes) - } - -and copy_virtual_flag : - From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = - function - | From.Asttypes.Virtual -> To.Asttypes.Virtual - | From.Asttypes.Concrete -> To.Asttypes.Concrete - -and copy_include_description : - From.Parsetree.include_description -> - To.Parsetree.include_description - = - fun x -> - copy_include_infos copy_module_type x - -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.include_infos -> - 'g0 To.Parsetree.include_infos - = - fun f0 -> - fun - { From.Parsetree.pincl_mod = pincl_mod; - From.Parsetree.pincl_loc = pincl_loc; - From.Parsetree.pincl_attributes = pincl_attributes } - -> - { - To.Parsetree.pincl_mod = (f0 pincl_mod); - To.Parsetree.pincl_loc = (copy_location pincl_loc); - To.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } - -and copy_open_description : - From.Parsetree.open_description -> To.Parsetree.open_description = - fun - { From.Parsetree.popen_lid = popen_lid; - From.Parsetree.popen_override = popen_override; - From.Parsetree.popen_loc = popen_loc; - From.Parsetree.popen_attributes = popen_attributes } - -> - { - To.Parsetree.popen_lid = - (copy_loc copy_longident popen_lid); - To.Parsetree.popen_override = - (copy_override_flag popen_override); - To.Parsetree.popen_loc = (copy_location popen_loc); - To.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } - -and copy_override_flag : - From.Asttypes.override_flag -> To.Asttypes.override_flag = - function - | From.Asttypes.Override -> To.Asttypes.Override - | From.Asttypes.Fresh -> To.Asttypes.Fresh - -and copy_module_type_declaration : - From.Parsetree.module_type_declaration -> - To.Parsetree.module_type_declaration +let rec copy_out_type_extension : + Ast_405.Outcometree.out_type_extension -> + Ast_406.Outcometree.out_type_extension = fun - { From.Parsetree.pmtd_name = pmtd_name; - From.Parsetree.pmtd_type = pmtd_type; - From.Parsetree.pmtd_attributes = pmtd_attributes; - From.Parsetree.pmtd_loc = pmtd_loc } - -> + { Ast_405.Outcometree.otyext_name = otyext_name; + Ast_405.Outcometree.otyext_params = otyext_params; + Ast_405.Outcometree.otyext_constructors = otyext_constructors; + Ast_405.Outcometree.otyext_private = otyext_private } + -> { - To.Parsetree.pmtd_name = - (copy_loc (fun x -> x) pmtd_name); - To.Parsetree.pmtd_type = - (copy_option copy_module_type pmtd_type); - To.Parsetree.pmtd_attributes = - (copy_attributes pmtd_attributes); - To.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } - -and copy_module_declaration : - From.Parsetree.module_declaration -> - To.Parsetree.module_declaration - = - fun - { From.Parsetree.pmd_name = pmd_name; - From.Parsetree.pmd_type = pmd_type; - From.Parsetree.pmd_attributes = pmd_attributes; - From.Parsetree.pmd_loc = pmd_loc } - -> - { - To.Parsetree.pmd_name = - (copy_loc (fun x -> x) pmd_name); - To.Parsetree.pmd_type = - (copy_module_type pmd_type); - To.Parsetree.pmd_attributes = - (copy_attributes pmd_attributes); - To.Parsetree.pmd_loc = (copy_location pmd_loc) - } - -and copy_type_extension : - From.Parsetree.type_extension -> To.Parsetree.type_extension = - fun - { From.Parsetree.ptyext_path = ptyext_path; - From.Parsetree.ptyext_params = ptyext_params; - From.Parsetree.ptyext_constructors = ptyext_constructors; - From.Parsetree.ptyext_private = ptyext_private; - From.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - To.Parsetree.ptyext_path = - (copy_loc copy_longident ptyext_path); - To.Parsetree.ptyext_params = + Ast_406.Outcometree.otyext_name = otyext_name; + Ast_406.Outcometree.otyext_params = + (List.map (fun x -> x) otyext_params); + Ast_406.Outcometree.otyext_constructors = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptyext_params); - To.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor - ptyext_constructors); - To.Parsetree.ptyext_private = - (copy_private_flag ptyext_private); - To.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } - -and copy_extension_constructor : - From.Parsetree.extension_constructor -> - To.Parsetree.extension_constructor - = - fun - { From.Parsetree.pext_name = pext_name; - From.Parsetree.pext_kind = pext_kind; - From.Parsetree.pext_loc = pext_loc; - From.Parsetree.pext_attributes = pext_attributes } - -> - { - To.Parsetree.pext_name = - (copy_loc (fun x -> x) pext_name); - To.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - To.Parsetree.pext_loc = (copy_location pext_loc); - To.Parsetree.pext_attributes = - (copy_attributes pext_attributes) - } - -and copy_extension_constructor_kind : - From.Parsetree.extension_constructor_kind -> - To.Parsetree.extension_constructor_kind - = - function - | From.Parsetree.Pext_decl (x0,x1) -> - To.Parsetree.Pext_decl - ((copy_constructor_arguments x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pext_rebind x0 -> - To.Parsetree.Pext_rebind - (copy_loc copy_longident x0) - -and copy_type_declaration : - From.Parsetree.type_declaration -> To.Parsetree.type_declaration = - fun - { From.Parsetree.ptype_name = ptype_name; - From.Parsetree.ptype_params = ptype_params; - From.Parsetree.ptype_cstrs = ptype_cstrs; - From.Parsetree.ptype_kind = ptype_kind; - From.Parsetree.ptype_private = ptype_private; - From.Parsetree.ptype_manifest = ptype_manifest; - From.Parsetree.ptype_attributes = ptype_attributes; - From.Parsetree.ptype_loc = ptype_loc } - -> - { - To.Parsetree.ptype_name = - (copy_loc (fun x -> x) ptype_name); - To.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptype_params); - To.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0,x1,x2) = x in - ((copy_core_type x0), - (copy_core_type x1), - (copy_location x2))) ptype_cstrs); - To.Parsetree.ptype_kind = - (copy_type_kind ptype_kind); - To.Parsetree.ptype_private = - (copy_private_flag ptype_private); - To.Parsetree.ptype_manifest = - (copy_option copy_core_type ptype_manifest); - To.Parsetree.ptype_attributes = - (copy_attributes ptype_attributes); - To.Parsetree.ptype_loc = (copy_location ptype_loc) - } - -and copy_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = - function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - -and copy_type_kind : - From.Parsetree.type_kind -> To.Parsetree.type_kind = - function - | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract - | From.Parsetree.Ptype_variant x0 -> - To.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | From.Parsetree.Ptype_record x0 -> - To.Parsetree.Ptype_record - (List.map copy_label_declaration x0) - | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open - -and copy_constructor_declaration : - From.Parsetree.constructor_declaration -> - To.Parsetree.constructor_declaration - = - fun - { From.Parsetree.pcd_name = pcd_name; - From.Parsetree.pcd_args = pcd_args; - From.Parsetree.pcd_res = pcd_res; - From.Parsetree.pcd_loc = pcd_loc; - From.Parsetree.pcd_attributes = pcd_attributes } - -> - { - To.Parsetree.pcd_name = - (copy_loc (fun x -> x) pcd_name); - To.Parsetree.pcd_args = - (copy_constructor_arguments pcd_args); - To.Parsetree.pcd_res = - (copy_option copy_core_type pcd_res); - To.Parsetree.pcd_loc = (copy_location pcd_loc); - To.Parsetree.pcd_attributes = - (copy_attributes pcd_attributes) - } - -and copy_constructor_arguments : - From.Parsetree.constructor_arguments -> - To.Parsetree.constructor_arguments - = - function - | From.Parsetree.Pcstr_tuple x0 -> - To.Parsetree.Pcstr_tuple - (List.map copy_core_type x0) - | From.Parsetree.Pcstr_record x0 -> - To.Parsetree.Pcstr_record - (List.map copy_label_declaration x0) - -and copy_label_declaration : - From.Parsetree.label_declaration -> To.Parsetree.label_declaration - = - fun - { From.Parsetree.pld_name = pld_name; - From.Parsetree.pld_mutable = pld_mutable; - From.Parsetree.pld_type = pld_type; - From.Parsetree.pld_loc = pld_loc; - From.Parsetree.pld_attributes = pld_attributes } - -> - { - To.Parsetree.pld_name = - (copy_loc (fun x -> x) pld_name); - To.Parsetree.pld_mutable = - (copy_mutable_flag pld_mutable); - To.Parsetree.pld_type = - (copy_core_type pld_type); - To.Parsetree.pld_loc = (copy_location pld_loc); - To.Parsetree.pld_attributes = - (copy_attributes pld_attributes) - } - -and copy_mutable_flag : - From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = - function - | From.Asttypes.Immutable -> To.Asttypes.Immutable - | From.Asttypes.Mutable -> To.Asttypes.Mutable - -and copy_variance : - From.Asttypes.variance -> To.Asttypes.variance = - function - | From.Asttypes.Covariant -> To.Asttypes.Covariant - | From.Asttypes.Contravariant -> To.Asttypes.Contravariant - | From.Asttypes.Invariant -> To.Asttypes.Invariant - -and copy_value_description : - From.Parsetree.value_description -> To.Parsetree.value_description - = - fun - { From.Parsetree.pval_name = pval_name; - From.Parsetree.pval_type = pval_type; - From.Parsetree.pval_prim = pval_prim; - From.Parsetree.pval_attributes = pval_attributes; - From.Parsetree.pval_loc = pval_loc } - -> - { - To.Parsetree.pval_name = - (copy_loc (fun x -> x) pval_name); - To.Parsetree.pval_type = - (copy_core_type pval_type); - To.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - To.Parsetree.pval_attributes = - (copy_attributes pval_attributes); - To.Parsetree.pval_loc = (copy_location pval_loc) - } - -and copy_arg_label : - From.Asttypes.arg_label -> To.Asttypes.arg_label = - function - | From.Asttypes.Nolabel -> To.Asttypes.Nolabel - | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 - | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 - -and copy_closed_flag : - From.Asttypes.closed_flag -> To.Asttypes.closed_flag = - function - | From.Asttypes.Closed -> To.Asttypes.Closed - | From.Asttypes.Open -> To.Asttypes.Open - -and copy_label : - From.Asttypes.label -> To.Asttypes.label = fun x -> x - -and copy_rec_flag : - From.Asttypes.rec_flag -> To.Asttypes.rec_flag = - function - | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive - | From.Asttypes.Recursive -> To.Asttypes.Recursive - -and copy_constant : - From.Parsetree.constant -> To.Parsetree.constant = - function - | From.Parsetree.Pconst_integer (x0,x1) -> - To.Parsetree.Pconst_integer (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 - | From.Parsetree.Pconst_string (x0,x1) -> - To.Parsetree.Pconst_string (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_float (x0,x1) -> - To.Parsetree.Pconst_float (x0, (copy_option (fun x -> x) x1)) - -and copy_option : 'f0 'g0 . ('f0 -> 'g0) -> 'f0 option -> 'g0 option = - fun f0 -> function | None -> None | Some x0 -> Some (f0 x0) - -and copy_longident : From.Longident.t -> To.Longident.t = - function - | From.Longident.Lident x0 -> To.Longident.Lident x0 - | From.Longident.Ldot (x0,x1) -> - To.Longident.Ldot ((copy_longident x0), x1) - | From.Longident.Lapply (x0,x1) -> - To.Longident.Lapply - ((copy_longident x0), (copy_longident x1)) - -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc - = - fun f0 -> - fun { From.Asttypes.txt = txt; From.Asttypes.loc = loc } -> - { - To.Asttypes.txt = (f0 txt); - To.Asttypes.loc = (copy_location loc) - } - -and copy_location : From.Location.t -> To.Location.t = - fun - { From.Location.loc_start = loc_start; - From.Location.loc_end = loc_end; - From.Location.loc_ghost = loc_ghost } - -> - { - To.Location.loc_start = (copy_Lexing_position loc_start); - To.Location.loc_end = (copy_Lexing_position loc_end); - To.Location.loc_ghost = (copy_bool loc_ghost) - } - -and copy_bool : bool -> bool = function | false -> false | true -> true - -and copy_Lexing_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum + (fun x -> + let (x0, x1, x2) = x in + (x0, (List.map copy_out_type x1), + (Option.map copy_out_type x2))) otyext_constructors); + Ast_406.Outcometree.otyext_private = (copy_private_flag otyext_private) } - -let rec copy_out_phrase : - From.Outcometree.out_phrase -> To.Outcometree.out_phrase = +and copy_out_phrase : + Ast_405.Outcometree.out_phrase -> Ast_406.Outcometree.out_phrase = function - | From.Outcometree.Ophr_eval (x0,x1) -> - To.Outcometree.Ophr_eval - ((copy_out_value x0), - (copy_out_type x1)) - | From.Outcometree.Ophr_signature x0 -> - To.Outcometree.Ophr_signature + | Ast_405.Outcometree.Ophr_eval (x0, x1) -> + Ast_406.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1)) + | Ast_405.Outcometree.Ophr_signature x0 -> + Ast_406.Outcometree.Ophr_signature (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_sig_item x0), - (copy_option copy_out_value x1))) x0) - | From.Outcometree.Ophr_exception x0 -> - To.Outcometree.Ophr_exception - (let (x0,x1) = x0 in - ((copy_exn x0), (copy_out_value x1))) - -and copy_exn : exn -> exn = fun x -> x - + (fun x -> + let (x0, x1) = x in + ((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0) + | Ast_405.Outcometree.Ophr_exception x0 -> + Ast_406.Outcometree.Ophr_exception + (let (x0, x1) = x0 in (x0, (copy_out_value x1))) and copy_out_sig_item : - From.Outcometree.out_sig_item -> To.Outcometree.out_sig_item = + Ast_405.Outcometree.out_sig_item -> Ast_406.Outcometree.out_sig_item = function - | From.Outcometree.Osig_class (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class - ((copy_bool x0), x1, + | Ast_405.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> + Ast_406.Outcometree.Osig_class + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_class_type (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class_type - ((copy_bool x0), x1, + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_405.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> + Ast_406.Outcometree.Osig_class_type + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_typext (x0,x1) -> - To.Outcometree.Osig_typext - ((copy_out_extension_constructor x0), - (copy_out_ext_status x1)) - | From.Outcometree.Osig_modtype (x0,x1) -> - To.Outcometree.Osig_modtype - (x0, (copy_out_module_type x1)) - | From.Outcometree.Osig_module (x0,x1,x2) -> - To.Outcometree.Osig_module - (x0, (copy_out_module_type x1), - (copy_out_rec_status x2)) - | From.Outcometree.Osig_type (x0,x1) -> - To.Outcometree.Osig_type - ((copy_out_type_decl x0), - (copy_out_rec_status x1)) - | From.Outcometree.Osig_value x0 -> - To.Outcometree.Osig_value - (copy_out_val_decl x0) - | From.Outcometree.Osig_ellipsis -> To.Outcometree.Osig_ellipsis - + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_405.Outcometree.Osig_typext (x0, x1) -> + Ast_406.Outcometree.Osig_typext + ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) + | Ast_405.Outcometree.Osig_modtype (x0, x1) -> + Ast_406.Outcometree.Osig_modtype (x0, (copy_out_module_type x1)) + | Ast_405.Outcometree.Osig_module (x0, x1, x2) -> + Ast_406.Outcometree.Osig_module + (x0, (copy_out_module_type x1), (copy_out_rec_status x2)) + | Ast_405.Outcometree.Osig_type (x0, x1) -> + Ast_406.Outcometree.Osig_type + ((copy_out_type_decl x0), (copy_out_rec_status x1)) + | Ast_405.Outcometree.Osig_value x0 -> + Ast_406.Outcometree.Osig_value (copy_out_val_decl x0) + | Ast_405.Outcometree.Osig_ellipsis -> Ast_406.Outcometree.Osig_ellipsis and copy_out_val_decl : - From.Outcometree.out_val_decl -> To.Outcometree.out_val_decl = + Ast_405.Outcometree.out_val_decl -> Ast_406.Outcometree.out_val_decl = fun - { From.Outcometree.oval_name = oval_name; - From.Outcometree.oval_type = oval_type; - From.Outcometree.oval_prims = oval_prims; - From.Outcometree.oval_attributes = oval_attributes } - -> + { Ast_405.Outcometree.oval_name = oval_name; + Ast_405.Outcometree.oval_type = oval_type; + Ast_405.Outcometree.oval_prims = oval_prims; + Ast_405.Outcometree.oval_attributes = oval_attributes } + -> { - To.Outcometree.oval_name = oval_name; - To.Outcometree.oval_type = - (copy_out_type oval_type); - To.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); - To.Outcometree.oval_attributes = + Ast_406.Outcometree.oval_name = oval_name; + Ast_406.Outcometree.oval_type = (copy_out_type oval_type); + Ast_406.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); + Ast_406.Outcometree.oval_attributes = (List.map copy_out_attribute oval_attributes) } - and copy_out_type_decl : - From.Outcometree.out_type_decl -> To.Outcometree.out_type_decl = + Ast_405.Outcometree.out_type_decl -> Ast_406.Outcometree.out_type_decl = fun - { From.Outcometree.otype_name = otype_name; - From.Outcometree.otype_params = otype_params; - From.Outcometree.otype_type = otype_type; - From.Outcometree.otype_private = otype_private; - From.Outcometree.otype_immediate = otype_immediate; - From.Outcometree.otype_unboxed = otype_unboxed; - From.Outcometree.otype_cstrs = otype_cstrs } - -> + { Ast_405.Outcometree.otype_name = otype_name; + Ast_405.Outcometree.otype_params = otype_params; + Ast_405.Outcometree.otype_type = otype_type; + Ast_405.Outcometree.otype_private = otype_private; + Ast_405.Outcometree.otype_immediate = otype_immediate; + Ast_405.Outcometree.otype_unboxed = otype_unboxed; + Ast_405.Outcometree.otype_cstrs = otype_cstrs } + -> { - To.Outcometree.otype_name = otype_name; - To.Outcometree.otype_params = + Ast_406.Outcometree.otype_name = otype_name; + Ast_406.Outcometree.otype_params = (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) otype_params); - To.Outcometree.otype_type = - (copy_out_type otype_type); - To.Outcometree.otype_private = - (copy_From_Asttypes_private_flag otype_private); - To.Outcometree.otype_immediate = (copy_bool otype_immediate); - To.Outcometree.otype_unboxed = (copy_bool otype_unboxed); - To.Outcometree.otype_cstrs = + Ast_406.Outcometree.otype_type = (copy_out_type otype_type); + Ast_406.Outcometree.otype_private = (copy_private_flag otype_private); + Ast_406.Outcometree.otype_immediate = otype_immediate; + Ast_406.Outcometree.otype_unboxed = otype_unboxed; + Ast_406.Outcometree.otype_cstrs = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_type x0), - (copy_out_type x1))) otype_cstrs) + (fun x -> + let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1))) + otype_cstrs) } - and copy_out_module_type : - From.Outcometree.out_module_type -> To.Outcometree.out_module_type + Ast_405.Outcometree.out_module_type -> Ast_406.Outcometree.out_module_type = function - | From.Outcometree.Omty_abstract -> To.Outcometree.Omty_abstract - | From.Outcometree.Omty_functor (x0,x1,x2) -> - To.Outcometree.Omty_functor - (x0, (copy_option copy_out_module_type x1), - (copy_out_module_type x2)) - | From.Outcometree.Omty_ident x0 -> - To.Outcometree.Omty_ident (copy_out_ident x0) - | From.Outcometree.Omty_signature x0 -> - To.Outcometree.Omty_signature - (List.map copy_out_sig_item x0) - | From.Outcometree.Omty_alias x0 -> - To.Outcometree.Omty_alias (copy_out_ident x0) - + | Ast_405.Outcometree.Omty_abstract -> Ast_406.Outcometree.Omty_abstract + | Ast_405.Outcometree.Omty_functor (x0, x1, x2) -> + Ast_406.Outcometree.Omty_functor + (x0, (Option.map copy_out_module_type x1), (copy_out_module_type x2)) + | Ast_405.Outcometree.Omty_ident x0 -> + Ast_406.Outcometree.Omty_ident (copy_out_ident x0) + | Ast_405.Outcometree.Omty_signature x0 -> + Ast_406.Outcometree.Omty_signature (List.map copy_out_sig_item x0) + | Ast_405.Outcometree.Omty_alias x0 -> + Ast_406.Outcometree.Omty_alias (copy_out_ident x0) and copy_out_ext_status : - From.Outcometree.out_ext_status -> To.Outcometree.out_ext_status = + Ast_405.Outcometree.out_ext_status -> Ast_406.Outcometree.out_ext_status = function - | From.Outcometree.Oext_first -> To.Outcometree.Oext_first - | From.Outcometree.Oext_next -> To.Outcometree.Oext_next - | From.Outcometree.Oext_exception -> To.Outcometree.Oext_exception - + | Ast_405.Outcometree.Oext_first -> Ast_406.Outcometree.Oext_first + | Ast_405.Outcometree.Oext_next -> Ast_406.Outcometree.Oext_next + | Ast_405.Outcometree.Oext_exception -> Ast_406.Outcometree.Oext_exception and copy_out_extension_constructor : - From.Outcometree.out_extension_constructor -> - To.Outcometree.out_extension_constructor + Ast_405.Outcometree.out_extension_constructor -> + Ast_406.Outcometree.out_extension_constructor = fun - { From.Outcometree.oext_name = oext_name; - From.Outcometree.oext_type_name = oext_type_name; - From.Outcometree.oext_type_params = oext_type_params; - From.Outcometree.oext_args = oext_args; - From.Outcometree.oext_ret_type = oext_ret_type; - From.Outcometree.oext_private = oext_private } - -> + { Ast_405.Outcometree.oext_name = oext_name; + Ast_405.Outcometree.oext_type_name = oext_type_name; + Ast_405.Outcometree.oext_type_params = oext_type_params; + Ast_405.Outcometree.oext_args = oext_args; + Ast_405.Outcometree.oext_ret_type = oext_ret_type; + Ast_405.Outcometree.oext_private = oext_private } + -> { - To.Outcometree.oext_name = oext_name; - To.Outcometree.oext_type_name = oext_type_name; - To.Outcometree.oext_type_params = - (List.map (fun x -> x) oext_type_params); - To.Outcometree.oext_args = - (List.map copy_out_type oext_args); - To.Outcometree.oext_ret_type = - (copy_option copy_out_type oext_ret_type); - To.Outcometree.oext_private = - (copy_From_Asttypes_private_flag oext_private) + Ast_406.Outcometree.oext_name = oext_name; + Ast_406.Outcometree.oext_type_name = oext_type_name; + Ast_406.Outcometree.oext_type_params = + (List.map (fun x -> x) oext_type_params); + Ast_406.Outcometree.oext_args = (List.map copy_out_type oext_args); + Ast_406.Outcometree.oext_ret_type = + (Option.map copy_out_type oext_ret_type); + Ast_406.Outcometree.oext_private = (copy_private_flag oext_private) } - -and copy_From_Asttypes_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = +and copy_private_flag : + Ast_405.Asttypes.private_flag -> Ast_406.Asttypes.private_flag = function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - + | Ast_405.Asttypes.Private -> Ast_406.Asttypes.Private + | Ast_405.Asttypes.Public -> Ast_406.Asttypes.Public and copy_out_rec_status : - From.Outcometree.out_rec_status -> To.Outcometree.out_rec_status = + Ast_405.Outcometree.out_rec_status -> Ast_406.Outcometree.out_rec_status = function - | From.Outcometree.Orec_not -> To.Outcometree.Orec_not - | From.Outcometree.Orec_first -> To.Outcometree.Orec_first - | From.Outcometree.Orec_next -> To.Outcometree.Orec_next - + | Ast_405.Outcometree.Orec_not -> Ast_406.Outcometree.Orec_not + | Ast_405.Outcometree.Orec_first -> Ast_406.Outcometree.Orec_first + | Ast_405.Outcometree.Orec_next -> Ast_406.Outcometree.Orec_next and copy_out_class_type : - From.Outcometree.out_class_type -> To.Outcometree.out_class_type = - function - | From.Outcometree.Octy_constr (x0,x1) -> - To.Outcometree.Octy_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Octy_arrow (x0,x1,x2) -> - To.Outcometree.Octy_arrow - (x0, (copy_out_type x1), - (copy_out_class_type x2)) - | From.Outcometree.Octy_signature (x0,x1) -> - To.Outcometree.Octy_signature - ((copy_option copy_out_type x0), + Ast_405.Outcometree.out_class_type -> Ast_406.Outcometree.out_class_type = + function + | Ast_405.Outcometree.Octy_constr (x0, x1) -> + Ast_406.Outcometree.Octy_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_405.Outcometree.Octy_arrow (x0, x1, x2) -> + Ast_406.Outcometree.Octy_arrow + (x0, (copy_out_type x1), (copy_out_class_type x2)) + | Ast_405.Outcometree.Octy_signature (x0, x1) -> + Ast_406.Outcometree.Octy_signature + ((Option.map copy_out_type x0), (List.map copy_out_class_sig_item x1)) - and copy_out_class_sig_item : - From.Outcometree.out_class_sig_item -> - To.Outcometree.out_class_sig_item + Ast_405.Outcometree.out_class_sig_item -> + Ast_406.Outcometree.out_class_sig_item = function - | From.Outcometree.Ocsg_constraint (x0,x1) -> - To.Outcometree.Ocsg_constraint - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Ocsg_method (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_method - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - | From.Outcometree.Ocsg_value (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_value - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - + | Ast_405.Outcometree.Ocsg_constraint (x0, x1) -> + Ast_406.Outcometree.Ocsg_constraint + ((copy_out_type x0), (copy_out_type x1)) + | Ast_405.Outcometree.Ocsg_method (x0, x1, x2, x3) -> + Ast_406.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3)) + | Ast_405.Outcometree.Ocsg_value (x0, x1, x2, x3) -> + Ast_406.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3)) and copy_out_type : - From.Outcometree.out_type -> To.Outcometree.out_type = - function - | From.Outcometree.Otyp_abstract -> To.Outcometree.Otyp_abstract - | From.Outcometree.Otyp_open -> To.Outcometree.Otyp_open - | From.Outcometree.Otyp_alias (x0,x1) -> - To.Outcometree.Otyp_alias - ((copy_out_type x0), x1) - | From.Outcometree.Otyp_arrow (x0,x1,x2) -> - To.Outcometree.Otyp_arrow - (x0, (copy_out_type x1), - (copy_out_type x2)) - | From.Outcometree.Otyp_class (x0,x1,x2) -> - To.Outcometree.Otyp_class - ((copy_bool x0), (copy_out_ident x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_constr (x0,x1) -> - To.Outcometree.Otyp_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Otyp_manifest (x0,x1) -> - To.Outcometree.Otyp_manifest - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Otyp_object (x0,x1) -> - To.Outcometree.Otyp_object - ((List.map - (fun x -> - let (x0,x1) = x in - (x0, (copy_out_type x1))) x0), - (copy_option copy_bool x1)) - | From.Outcometree.Otyp_record x0 -> - To.Outcometree.Otyp_record + Ast_405.Outcometree.out_type -> Ast_406.Outcometree.out_type = + function + | Ast_405.Outcometree.Otyp_abstract -> Ast_406.Outcometree.Otyp_abstract + | Ast_405.Outcometree.Otyp_open -> Ast_406.Outcometree.Otyp_open + | Ast_405.Outcometree.Otyp_alias (x0, x1) -> + Ast_406.Outcometree.Otyp_alias ((copy_out_type x0), x1) + | Ast_405.Outcometree.Otyp_arrow (x0, x1, x2) -> + Ast_406.Outcometree.Otyp_arrow + (x0, (copy_out_type x1), (copy_out_type x2)) + | Ast_405.Outcometree.Otyp_class (x0, x1, x2) -> + Ast_406.Outcometree.Otyp_class + (x0, (copy_out_ident x1), (List.map copy_out_type x2)) + | Ast_405.Outcometree.Otyp_constr (x0, x1) -> + Ast_406.Outcometree.Otyp_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_405.Outcometree.Otyp_manifest (x0, x1) -> + Ast_406.Outcometree.Otyp_manifest + ((copy_out_type x0), (copy_out_type x1)) + | Ast_405.Outcometree.Otyp_object (x0, x1) -> + Ast_406.Outcometree.Otyp_object + ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0), + (Option.map (fun x -> x) x1)) + | Ast_405.Outcometree.Otyp_record x0 -> + Ast_406.Outcometree.Otyp_record (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), (copy_out_type x2))) - x0) - | From.Outcometree.Otyp_stuff x0 -> To.Outcometree.Otyp_stuff x0 - | From.Outcometree.Otyp_sum x0 -> - To.Outcometree.Otyp_sum + (fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0) + | Ast_405.Outcometree.Otyp_stuff x0 -> Ast_406.Outcometree.Otyp_stuff x0 + | Ast_405.Outcometree.Otyp_sum x0 -> + Ast_406.Outcometree.Otyp_sum (List.map - (fun x -> - let (x0,x1,x2) = x in + (fun x -> + let (x0, x1, x2) = x in (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) x0) - | From.Outcometree.Otyp_tuple x0 -> - To.Outcometree.Otyp_tuple - (List.map copy_out_type x0) - | From.Outcometree.Otyp_var (x0,x1) -> - To.Outcometree.Otyp_var ((copy_bool x0), x1) - | From.Outcometree.Otyp_variant (x0,x1,x2,x3) -> - To.Outcometree.Otyp_variant - ((copy_bool x0), (copy_out_variant x1), - (copy_bool x2), - (copy_option (fun x -> List.map (fun x -> x) x) x3)) - | From.Outcometree.Otyp_poly (x0,x1) -> - To.Outcometree.Otyp_poly - ((List.map (fun x -> x) x0), (copy_out_type x1)) - | From.Outcometree.Otyp_module (x0,x1,x2) -> - To.Outcometree.Otyp_module - (x0, (List.map (fun x -> x) x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_attribute (x0,x1) -> - To.Outcometree.Otyp_attribute - ((copy_out_type x0), - (copy_out_attribute x1)) - + (Option.map copy_out_type x2))) x0) + | Ast_405.Outcometree.Otyp_tuple x0 -> + Ast_406.Outcometree.Otyp_tuple (List.map copy_out_type x0) + | Ast_405.Outcometree.Otyp_var (x0, x1) -> + Ast_406.Outcometree.Otyp_var (x0, x1) + | Ast_405.Outcometree.Otyp_variant (x0, x1, x2, x3) -> + Ast_406.Outcometree.Otyp_variant + (x0, (copy_out_variant x1), x2, + (Option.map (fun x -> List.map (fun x -> x) x) x3)) + | Ast_405.Outcometree.Otyp_poly (x0, x1) -> + Ast_406.Outcometree.Otyp_poly + ((List.map (fun x -> x) x0), (copy_out_type x1)) + | Ast_405.Outcometree.Otyp_module (x0, x1, x2) -> + Ast_406.Outcometree.Otyp_module + (x0, (List.map (fun x -> x) x1), (List.map copy_out_type x2)) + | Ast_405.Outcometree.Otyp_attribute (x0, x1) -> + Ast_406.Outcometree.Otyp_attribute + ((copy_out_type x0), (copy_out_attribute x1)) and copy_out_attribute : - From.Outcometree.out_attribute -> To.Outcometree.out_attribute = - fun { From.Outcometree.oattr_name = oattr_name } -> - { To.Outcometree.oattr_name = oattr_name } - + Ast_405.Outcometree.out_attribute -> Ast_406.Outcometree.out_attribute = + fun { Ast_405.Outcometree.oattr_name = oattr_name } -> + { Ast_406.Outcometree.oattr_name = oattr_name } and copy_out_variant : - From.Outcometree.out_variant -> To.Outcometree.out_variant = + Ast_405.Outcometree.out_variant -> Ast_406.Outcometree.out_variant = function - | From.Outcometree.Ovar_fields x0 -> - To.Outcometree.Ovar_fields + | Ast_405.Outcometree.Ovar_fields x0 -> + Ast_406.Outcometree.Ovar_fields (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), - (List.map copy_out_type x2))) x0) - | From.Outcometree.Ovar_typ x0 -> - To.Outcometree.Ovar_typ (copy_out_type x0) - + (fun x -> + let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2))) + x0) + | Ast_405.Outcometree.Ovar_typ x0 -> + Ast_406.Outcometree.Ovar_typ (copy_out_type x0) and copy_out_value : - From.Outcometree.out_value -> To.Outcometree.out_value = - function - | From.Outcometree.Oval_array x0 -> - To.Outcometree.Oval_array - (List.map copy_out_value x0) - | From.Outcometree.Oval_char x0 -> To.Outcometree.Oval_char x0 - | From.Outcometree.Oval_constr (x0,x1) -> - To.Outcometree.Oval_constr - ((copy_out_ident x0), - (List.map copy_out_value x1)) - | From.Outcometree.Oval_ellipsis -> To.Outcometree.Oval_ellipsis - | From.Outcometree.Oval_float x0 -> - To.Outcometree.Oval_float (copy_float x0) - | From.Outcometree.Oval_int x0 -> To.Outcometree.Oval_int x0 - | From.Outcometree.Oval_int32 x0 -> To.Outcometree.Oval_int32 x0 - | From.Outcometree.Oval_int64 x0 -> To.Outcometree.Oval_int64 x0 - | From.Outcometree.Oval_nativeint x0 -> - To.Outcometree.Oval_nativeint x0 - | From.Outcometree.Oval_list x0 -> - To.Outcometree.Oval_list - (List.map copy_out_value x0) - | From.Outcometree.Oval_printer x0 -> - To.Outcometree.Oval_printer x0 - | From.Outcometree.Oval_record x0 -> - To.Outcometree.Oval_record + Ast_405.Outcometree.out_value -> Ast_406.Outcometree.out_value = + function + | Ast_405.Outcometree.Oval_array x0 -> + Ast_406.Outcometree.Oval_array (List.map copy_out_value x0) + | Ast_405.Outcometree.Oval_char x0 -> Ast_406.Outcometree.Oval_char x0 + | Ast_405.Outcometree.Oval_constr (x0, x1) -> + Ast_406.Outcometree.Oval_constr + ((copy_out_ident x0), (List.map copy_out_value x1)) + | Ast_405.Outcometree.Oval_ellipsis -> Ast_406.Outcometree.Oval_ellipsis + | Ast_405.Outcometree.Oval_float x0 -> Ast_406.Outcometree.Oval_float x0 + | Ast_405.Outcometree.Oval_int x0 -> Ast_406.Outcometree.Oval_int x0 + | Ast_405.Outcometree.Oval_int32 x0 -> Ast_406.Outcometree.Oval_int32 x0 + | Ast_405.Outcometree.Oval_int64 x0 -> Ast_406.Outcometree.Oval_int64 x0 + | Ast_405.Outcometree.Oval_nativeint x0 -> + Ast_406.Outcometree.Oval_nativeint x0 + | Ast_405.Outcometree.Oval_list x0 -> + Ast_406.Outcometree.Oval_list (List.map copy_out_value x0) + | Ast_405.Outcometree.Oval_printer x0 -> + Ast_406.Outcometree.Oval_printer x0 + | Ast_405.Outcometree.Oval_record x0 -> + Ast_406.Outcometree.Oval_record (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_ident x0), - (copy_out_value x1))) x0) - | From.Outcometree.Oval_string x0 -> + (fun x -> + let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1))) + x0) + | Ast_405.Outcometree.Oval_string x0 -> To.Outcometree.Oval_string (x0, max_int, Ostr_string) - | From.Outcometree.Oval_stuff x0 -> To.Outcometree.Oval_stuff x0 - | From.Outcometree.Oval_tuple x0 -> - To.Outcometree.Oval_tuple - (List.map copy_out_value x0) - | From.Outcometree.Oval_variant (x0,x1) -> - To.Outcometree.Oval_variant - (x0, (copy_option copy_out_value x1)) - -and copy_float : float -> float = fun x -> x - + | Ast_405.Outcometree.Oval_stuff x0 -> Ast_406.Outcometree.Oval_stuff x0 + | Ast_405.Outcometree.Oval_tuple x0 -> + Ast_406.Outcometree.Oval_tuple (List.map copy_out_value x0) + | Ast_405.Outcometree.Oval_variant (x0, x1) -> + Ast_406.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1)) and copy_out_ident : - From.Outcometree.out_ident -> To.Outcometree.out_ident = - function - | From.Outcometree.Oide_apply (x0,x1) -> - To.Outcometree.Oide_apply - ((copy_out_ident x0), - (copy_out_ident x1)) - | From.Outcometree.Oide_dot (x0,x1) -> - To.Outcometree.Oide_dot - ((copy_out_ident x0), x1) - | From.Outcometree.Oide_ident x0 -> To.Outcometree.Oide_ident x0 - -let rec copy_toplevel_phrase : - From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = - function - | From.Parsetree.Ptop_def x0 -> - To.Parsetree.Ptop_def (copy_structure x0) - | From.Parsetree.Ptop_dir (x0,x1) -> - To.Parsetree.Ptop_dir - (x0, (copy_directive_argument x1)) - -and copy_directive_argument : - From.Parsetree.directive_argument -> To.Parsetree.directive_argument = - function - | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none - | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 - | From.Parsetree.Pdir_int (x0,x1) -> - To.Parsetree.Pdir_int (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pdir_ident x0 -> - To.Parsetree.Pdir_ident (copy_longident x0) - | From.Parsetree.Pdir_bool x0 -> - To.Parsetree.Pdir_bool (copy_bool x0) - -let copy_out_type_extension : - From.Outcometree.out_type_extension -> To.Outcometree.out_type_extension = - fun - { From.Outcometree.otyext_name = otyext_name; - From.Outcometree.otyext_params = otyext_params; - From.Outcometree.otyext_constructors = otyext_constructors; - From.Outcometree.otyext_private = otyext_private } - -> - { - To.Outcometree.otyext_name = otyext_name; - To.Outcometree.otyext_params = - (List.map (fun x -> x) otyext_params); - To.Outcometree.otyext_constructors = - (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) - otyext_constructors); - To.Outcometree.otyext_private = - (copy_private_flag otyext_private) - } - -let copy_cases x = List.map copy_case x -let copy_pat = copy_pattern -let copy_expr = copy_expression -let copy_typ = copy_core_type + Ast_405.Outcometree.out_ident -> Ast_406.Outcometree.out_ident = + function + | Ast_405.Outcometree.Oide_apply (x0, x1) -> + Ast_406.Outcometree.Oide_apply + ((copy_out_ident x0), (copy_out_ident x1)) + | Ast_405.Outcometree.Oide_dot (x0, x1) -> + Ast_406.Outcometree.Oide_dot ((copy_out_ident x0), x1) + | Ast_405.Outcometree.Oide_ident x0 -> Ast_406.Outcometree.Oide_ident x0 diff --git a/src/vendored-omp/src/migrate_parsetree_406_405.ml b/src/vendored-omp/src/migrate_parsetree_406_405.ml index 944378c8b..a97014380 100644 --- a/src/vendored-omp/src/migrate_parsetree_406_405.ml +++ b/src/vendored-omp/src/migrate_parsetree_406_405.ml @@ -15,116 +15,3 @@ include Migrate_parsetree_406_405_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - (*$*) - } as mapper) -> - let module R = Migrate_parsetree_405_406_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_406_405_migrate.ml b/src/vendored-omp/src/migrate_parsetree_406_405_migrate.ml index b0757d534..88b994f2e 100644 --- a/src/vendored-omp/src/migrate_parsetree_406_405_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_406_405_migrate.ml @@ -1,1724 +1,300 @@ -(**************************************************************************) -(* *) -(* OCaml Migrate Parsetree *) -(* *) -(* Frédéric Bour *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2017 Institut National de Recherche en Informatique et *) -(* en Automatique (INRIA). *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -module Def = Migrate_parsetree_def +open Stdlib0 module From = Ast_406 module To = Ast_405 - -let migration_error location feature = - raise (Def.Migration_error (feature, location)) - -let rec copy_expression : - From.Parsetree.expression -> To.Parsetree.expression = - fun - { From.Parsetree.pexp_desc = pexp_desc; - From.Parsetree.pexp_loc = pexp_loc; - From.Parsetree.pexp_attributes = pexp_attributes } - -> - { - To.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - To.Parsetree.pexp_loc = (copy_location pexp_loc); - To.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } - -and copy_expression_desc : - From.Parsetree.expression_desc -> To.Parsetree.expression_desc = - function - | From.Parsetree.Pexp_ident x0 -> - To.Parsetree.Pexp_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_constant x0 -> - To.Parsetree.Pexp_constant (copy_constant x0) - | From.Parsetree.Pexp_let (x0,x1,x2) -> - To.Parsetree.Pexp_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_expression x2)) - | From.Parsetree.Pexp_function x0 -> - To.Parsetree.Pexp_function - (List.map copy_case x0) - | From.Parsetree.Pexp_fun (x0,x1,x2,x3) -> - To.Parsetree.Pexp_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_expression x3)) - | From.Parsetree.Pexp_apply (x0,x1) -> - To.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pexp_match (x0,x1) -> - To.Parsetree.Pexp_match - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_try (x0,x1) -> - To.Parsetree.Pexp_try - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_tuple x0 -> - To.Parsetree.Pexp_tuple - (List.map copy_expression x0) - | From.Parsetree.Pexp_construct (x0,x1) -> - To.Parsetree.Pexp_construct - ((copy_loc copy_longident x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_variant (x0,x1) -> - To.Parsetree.Pexp_variant - ((copy_label x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_record (x0,x1) -> - To.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_expression x1))) x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_field (x0,x1) -> - To.Parsetree.Pexp_field - ((copy_expression x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pexp_setfield (x0,x1,x2) -> - To.Parsetree.Pexp_setfield - ((copy_expression x0), - (copy_loc copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_array x0 -> - To.Parsetree.Pexp_array - (List.map copy_expression x0) - | From.Parsetree.Pexp_ifthenelse (x0,x1,x2) -> - To.Parsetree.Pexp_ifthenelse - ((copy_expression x0), - (copy_expression x1), - (copy_option copy_expression x2)) - | From.Parsetree.Pexp_sequence (x0,x1) -> - To.Parsetree.Pexp_sequence - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_while (x0,x1) -> - To.Parsetree.Pexp_while - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_for (x0,x1,x2,x3,x4) -> - To.Parsetree.Pexp_for - ((copy_pattern x0), - (copy_expression x1), - (copy_expression x2), - (copy_direction_flag x3), - (copy_expression x4)) - | From.Parsetree.Pexp_constraint (x0,x1) -> - To.Parsetree.Pexp_constraint - ((copy_expression x0), - (copy_core_type x1)) - | From.Parsetree.Pexp_coerce (x0,x1,x2) -> - To.Parsetree.Pexp_coerce - ((copy_expression x0), - (copy_option copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Pexp_send (x0,x1) -> - To.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc (fun x -> x) x1)) - | From.Parsetree.Pexp_new x0 -> - To.Parsetree.Pexp_new - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_setinstvar (x0,x1) -> - To.Parsetree.Pexp_setinstvar - ((copy_loc (fun x -> x) x0), - (copy_expression x1)) - | From.Parsetree.Pexp_override x0 -> - To.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_expression x1))) x0) - | From.Parsetree.Pexp_letmodule (x0,x1,x2) -> - To.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> x) x0), - (copy_module_expr x1), - (copy_expression x2)) - | From.Parsetree.Pexp_letexception (x0,x1) -> - To.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), - (copy_expression x1)) - | From.Parsetree.Pexp_assert x0 -> - To.Parsetree.Pexp_assert (copy_expression x0) - | From.Parsetree.Pexp_lazy x0 -> - To.Parsetree.Pexp_lazy (copy_expression x0) - | From.Parsetree.Pexp_poly (x0,x1) -> - To.Parsetree.Pexp_poly - ((copy_expression x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pexp_object x0 -> - To.Parsetree.Pexp_object - (copy_class_structure x0) - | From.Parsetree.Pexp_newtype (x0,x1) -> - To.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | From.Parsetree.Pexp_pack x0 -> - To.Parsetree.Pexp_pack (copy_module_expr x0) - | From.Parsetree.Pexp_open (x0,x1,x2) -> - To.Parsetree.Pexp_open - ((copy_override_flag x0), - (copy_loc copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_extension x0 -> - To.Parsetree.Pexp_extension (copy_extension x0) - | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable - -and copy_direction_flag : - From.Asttypes.direction_flag -> To.Asttypes.direction_flag = - function - | From.Asttypes.Upto -> To.Asttypes.Upto - | From.Asttypes.Downto -> To.Asttypes.Downto - -and copy_case : - From.Parsetree.case -> To.Parsetree.case = - fun - { From.Parsetree.pc_lhs = pc_lhs; - From.Parsetree.pc_guard = pc_guard; - From.Parsetree.pc_rhs = pc_rhs } - -> - { - To.Parsetree.pc_lhs = (copy_pattern pc_lhs); - To.Parsetree.pc_guard = - (copy_option copy_expression pc_guard); - To.Parsetree.pc_rhs = (copy_expression pc_rhs) - } - -and copy_value_binding : - From.Parsetree.value_binding -> To.Parsetree.value_binding = - fun - { From.Parsetree.pvb_pat = pvb_pat; - From.Parsetree.pvb_expr = pvb_expr; - From.Parsetree.pvb_attributes = pvb_attributes; - From.Parsetree.pvb_loc = pvb_loc } - -> - { - To.Parsetree.pvb_pat = (copy_pattern pvb_pat); - To.Parsetree.pvb_expr = - (copy_expression pvb_expr); - To.Parsetree.pvb_attributes = - (copy_attributes pvb_attributes); - To.Parsetree.pvb_loc = (copy_location pvb_loc) - } - -and copy_pattern : - From.Parsetree.pattern -> To.Parsetree.pattern = - fun - { From.Parsetree.ppat_desc = ppat_desc; - From.Parsetree.ppat_loc = ppat_loc; - From.Parsetree.ppat_attributes = ppat_attributes } - -> - { - To.Parsetree.ppat_desc = - (copy_pattern_desc ppat_desc); - To.Parsetree.ppat_loc = (copy_location ppat_loc); - To.Parsetree.ppat_attributes = - (copy_attributes ppat_attributes) - } - -and copy_pattern_desc : - From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc = - function - | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any - | From.Parsetree.Ppat_var x0 -> - To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_alias (x0,x1) -> - To.Parsetree.Ppat_alias - ((copy_pattern x0), - (copy_loc (fun x -> x) x1)) - | From.Parsetree.Ppat_constant x0 -> - To.Parsetree.Ppat_constant (copy_constant x0) - | From.Parsetree.Ppat_interval (x0,x1) -> - To.Parsetree.Ppat_interval - ((copy_constant x0), - (copy_constant x1)) - | From.Parsetree.Ppat_tuple x0 -> - To.Parsetree.Ppat_tuple - (List.map copy_pattern x0) - | From.Parsetree.Ppat_construct (x0,x1) -> - To.Parsetree.Ppat_construct - ((copy_loc copy_longident x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_variant (x0,x1) -> - To.Parsetree.Ppat_variant - ((copy_label x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_record (x0,x1) -> - To.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ppat_array x0 -> - To.Parsetree.Ppat_array - (List.map copy_pattern x0) - | From.Parsetree.Ppat_or (x0,x1) -> - To.Parsetree.Ppat_or - ((copy_pattern x0), - (copy_pattern x1)) - | From.Parsetree.Ppat_constraint (x0,x1) -> - To.Parsetree.Ppat_constraint - ((copy_pattern x0), - (copy_core_type x1)) - | From.Parsetree.Ppat_type x0 -> - To.Parsetree.Ppat_type - (copy_loc copy_longident x0) - | From.Parsetree.Ppat_lazy x0 -> - To.Parsetree.Ppat_lazy (copy_pattern x0) - | From.Parsetree.Ppat_unpack x0 -> - To.Parsetree.Ppat_unpack - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_exception x0 -> - To.Parsetree.Ppat_exception (copy_pattern x0) - | From.Parsetree.Ppat_extension x0 -> - To.Parsetree.Ppat_extension (copy_extension x0) - | From.Parsetree.Ppat_open (x0,x1) -> - To.Parsetree.Ppat_open - ((copy_loc copy_longident x0), - (copy_pattern x1)) - -and copy_core_type : - From.Parsetree.core_type -> To.Parsetree.core_type = - fun - { From.Parsetree.ptyp_desc = ptyp_desc; - From.Parsetree.ptyp_loc = ptyp_loc; - From.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - To.Parsetree.ptyp_desc = - (copy_core_type_desc ptyp_desc); - To.Parsetree.ptyp_loc = (copy_location ptyp_loc); - To.Parsetree.ptyp_attributes = - (copy_attributes ptyp_attributes) - } - -and copy_core_type_desc : - From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = - function - | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any - | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 - | From.Parsetree.Ptyp_arrow (x0,x1,x2) -> - To.Parsetree.Ptyp_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Ptyp_tuple x0 -> - To.Parsetree.Ptyp_tuple - (List.map copy_core_type x0) - | From.Parsetree.Ptyp_constr (x0,x1) -> - To.Parsetree.Ptyp_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_object (x0,x1) -> - To.Parsetree.Ptyp_object - ((List.map - (function - | From.Parsetree.Otag (x0,x1,x2) -> - (copy_loc (fun x -> x) x0, (copy_attributes x1), - (copy_core_type x2)) - | From.Parsetree.Oinherit _ -> - migration_error Location.none Def.Oinherit) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ptyp_class (x0,x1) -> - To.Parsetree.Ptyp_class - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_alias (x0,x1) -> - To.Parsetree.Ptyp_alias - ((copy_core_type x0), x1) - | From.Parsetree.Ptyp_variant (x0,x1,x2) -> - To.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), - (copy_closed_flag x1), - (copy_option (fun x -> List.map copy_label x) x2)) - | From.Parsetree.Ptyp_poly (x0,x1) -> - To.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), (copy_core_type x1)) - | From.Parsetree.Ptyp_package x0 -> - To.Parsetree.Ptyp_package (copy_package_type x0) - | From.Parsetree.Ptyp_extension x0 -> - To.Parsetree.Ptyp_extension (copy_extension x0) - -and copy_package_type : - From.Parsetree.package_type -> To.Parsetree.package_type = - fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_core_type x1))) x1)) - -and copy_row_field : - From.Parsetree.row_field -> To.Parsetree.row_field = - function - | From.Parsetree.Rtag (x0,x1,x2,x3) -> - To.Parsetree.Rtag - ((copy_label x0.txt), - (copy_attributes x1), (copy_bool x2), - (List.map copy_core_type x3)) - | From.Parsetree.Rinherit x0 -> - To.Parsetree.Rinherit (copy_core_type x0) - -and copy_attributes : - From.Parsetree.attributes -> To.Parsetree.attributes = - fun x -> List.map copy_attribute x - -and copy_attribute : - From.Parsetree.attribute -> To.Parsetree.attribute = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_payload : - From.Parsetree.payload -> To.Parsetree.payload = - function - | From.Parsetree.PStr x0 -> - To.Parsetree.PStr (copy_structure x0) - | From.Parsetree.PSig x0 -> - To.Parsetree.PSig (copy_signature x0) - | From.Parsetree.PTyp x0 -> - To.Parsetree.PTyp (copy_core_type x0) - | From.Parsetree.PPat (x0,x1) -> - To.Parsetree.PPat - ((copy_pattern x0), - (copy_option copy_expression x1)) - -and copy_structure : - From.Parsetree.structure -> To.Parsetree.structure = - fun x -> List.map copy_structure_item x - -and copy_structure_item : - From.Parsetree.structure_item -> To.Parsetree.structure_item = - fun - { From.Parsetree.pstr_desc = pstr_desc; - From.Parsetree.pstr_loc = pstr_loc } - -> - { - To.Parsetree.pstr_desc = - (copy_structure_item_desc pstr_desc); - To.Parsetree.pstr_loc = (copy_location pstr_loc) - } - -and copy_structure_item_desc : - From.Parsetree.structure_item_desc -> - To.Parsetree.structure_item_desc - = - function - | From.Parsetree.Pstr_eval (x0,x1) -> - To.Parsetree.Pstr_eval - ((copy_expression x0), - (copy_attributes x1)) - | From.Parsetree.Pstr_value (x0,x1) -> - To.Parsetree.Pstr_value - ((copy_rec_flag x0), - (List.map copy_value_binding x1)) - | From.Parsetree.Pstr_primitive x0 -> - To.Parsetree.Pstr_primitive - (copy_value_description x0) - | From.Parsetree.Pstr_type (x0,x1) -> - To.Parsetree.Pstr_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Pstr_typext x0 -> - To.Parsetree.Pstr_typext - (copy_type_extension x0) - | From.Parsetree.Pstr_exception x0 -> - To.Parsetree.Pstr_exception - (copy_extension_constructor x0) - | From.Parsetree.Pstr_module x0 -> - To.Parsetree.Pstr_module - (copy_module_binding x0) - | From.Parsetree.Pstr_recmodule x0 -> - To.Parsetree.Pstr_recmodule - (List.map copy_module_binding x0) - | From.Parsetree.Pstr_modtype x0 -> - To.Parsetree.Pstr_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Pstr_open x0 -> - To.Parsetree.Pstr_open - (copy_open_description x0) - | From.Parsetree.Pstr_class x0 -> - To.Parsetree.Pstr_class - (List.map copy_class_declaration x0) - | From.Parsetree.Pstr_class_type x0 -> - To.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Pstr_include x0 -> - To.Parsetree.Pstr_include - (copy_include_declaration x0) - | From.Parsetree.Pstr_attribute x0 -> - To.Parsetree.Pstr_attribute (copy_attribute x0) - | From.Parsetree.Pstr_extension (x0,x1) -> - To.Parsetree.Pstr_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_include_declaration : - From.Parsetree.include_declaration -> - To.Parsetree.include_declaration - = - fun x -> - copy_include_infos copy_module_expr x - -and copy_class_declaration : - From.Parsetree.class_declaration -> To.Parsetree.class_declaration - = - fun x -> - copy_class_infos copy_class_expr x - -and copy_class_expr : - From.Parsetree.class_expr -> To.Parsetree.class_expr = - fun - { From.Parsetree.pcl_desc = pcl_desc; - From.Parsetree.pcl_loc = pcl_loc; - From.Parsetree.pcl_attributes = pcl_attributes } - -> - { - To.Parsetree.pcl_desc = - (copy_class_expr_desc pcl_desc); - To.Parsetree.pcl_loc = (copy_location pcl_loc); - To.Parsetree.pcl_attributes = - (copy_attributes pcl_attributes) - } - -and copy_class_expr_desc : - From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = - function - | From.Parsetree.Pcl_constr (x0,x1) -> - To.Parsetree.Pcl_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcl_structure x0 -> - To.Parsetree.Pcl_structure - (copy_class_structure x0) - | From.Parsetree.Pcl_fun (x0,x1,x2,x3) -> - To.Parsetree.Pcl_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_class_expr x3)) - | From.Parsetree.Pcl_apply (x0,x1) -> - To.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pcl_let (x0,x1,x2) -> - To.Parsetree.Pcl_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_class_expr x2)) - | From.Parsetree.Pcl_constraint (x0,x1) -> - To.Parsetree.Pcl_constraint - ((copy_class_expr x0), - (copy_class_type x1)) - | From.Parsetree.Pcl_extension x0 -> - To.Parsetree.Pcl_extension (copy_extension x0) - | From.Parsetree.Pcl_open (_, loc, _) -> - migration_error loc.From.Location.loc Def.Pcl_open - -and copy_class_structure : - From.Parsetree.class_structure -> To.Parsetree.class_structure = - fun - { From.Parsetree.pcstr_self = pcstr_self; - From.Parsetree.pcstr_fields = pcstr_fields } - -> - { - To.Parsetree.pcstr_self = - (copy_pattern pcstr_self); - To.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } - -and copy_class_field : - From.Parsetree.class_field -> To.Parsetree.class_field = - fun - { From.Parsetree.pcf_desc = pcf_desc; - From.Parsetree.pcf_loc = pcf_loc; - From.Parsetree.pcf_attributes = pcf_attributes } - -> - { - To.Parsetree.pcf_desc = - (copy_class_field_desc pcf_desc); - To.Parsetree.pcf_loc = (copy_location pcf_loc); - To.Parsetree.pcf_attributes = - (copy_attributes pcf_attributes) - } - -and copy_class_field_desc : - From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = - function - | From.Parsetree.Pcf_inherit (x0,x1,x2) -> - To.Parsetree.Pcf_inherit - ((copy_override_flag x0), - (copy_class_expr x1), - (copy_option (copy_loc (fun x -> x)) x2)) - | From.Parsetree.Pcf_val x0 -> - To.Parsetree.Pcf_val - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_method x0 -> - To.Parsetree.Pcf_method - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_private_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_constraint x0 -> - To.Parsetree.Pcf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pcf_initializer x0 -> - To.Parsetree.Pcf_initializer - (copy_expression x0) - | From.Parsetree.Pcf_attribute x0 -> - To.Parsetree.Pcf_attribute (copy_attribute x0) - | From.Parsetree.Pcf_extension x0 -> - To.Parsetree.Pcf_extension (copy_extension x0) - -and copy_class_field_kind : - From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = - function - | From.Parsetree.Cfk_virtual x0 -> - To.Parsetree.Cfk_virtual (copy_core_type x0) - | From.Parsetree.Cfk_concrete (x0,x1) -> - To.Parsetree.Cfk_concrete - ((copy_override_flag x0), - (copy_expression x1)) - -and copy_module_binding : - From.Parsetree.module_binding -> To.Parsetree.module_binding = - fun - { From.Parsetree.pmb_name = pmb_name; - From.Parsetree.pmb_expr = pmb_expr; - From.Parsetree.pmb_attributes = pmb_attributes; - From.Parsetree.pmb_loc = pmb_loc } - -> - { - To.Parsetree.pmb_name = - (copy_loc (fun x -> x) pmb_name); - To.Parsetree.pmb_expr = - (copy_module_expr pmb_expr); - To.Parsetree.pmb_attributes = - (copy_attributes pmb_attributes); - To.Parsetree.pmb_loc = (copy_location pmb_loc) - } - -and copy_module_expr : - From.Parsetree.module_expr -> To.Parsetree.module_expr = - fun - { From.Parsetree.pmod_desc = pmod_desc; - From.Parsetree.pmod_loc = pmod_loc; - From.Parsetree.pmod_attributes = pmod_attributes } - -> - { - To.Parsetree.pmod_desc = - (copy_module_expr_desc pmod_desc); - To.Parsetree.pmod_loc = (copy_location pmod_loc); - To.Parsetree.pmod_attributes = - (copy_attributes pmod_attributes) - } - -and copy_module_expr_desc : - From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = - function - | From.Parsetree.Pmod_ident x0 -> - To.Parsetree.Pmod_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmod_structure x0 -> - To.Parsetree.Pmod_structure (copy_structure x0) - | From.Parsetree.Pmod_functor (x0,x1,x2) -> - To.Parsetree.Pmod_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_expr x2)) - | From.Parsetree.Pmod_apply (x0,x1) -> - To.Parsetree.Pmod_apply - ((copy_module_expr x0), - (copy_module_expr x1)) - | From.Parsetree.Pmod_constraint (x0,x1) -> - To.Parsetree.Pmod_constraint - ((copy_module_expr x0), - (copy_module_type x1)) - | From.Parsetree.Pmod_unpack x0 -> - To.Parsetree.Pmod_unpack (copy_expression x0) - | From.Parsetree.Pmod_extension x0 -> - To.Parsetree.Pmod_extension (copy_extension x0) - -and copy_module_type : - From.Parsetree.module_type -> To.Parsetree.module_type = - fun - { From.Parsetree.pmty_desc = pmty_desc; - From.Parsetree.pmty_loc = pmty_loc; - From.Parsetree.pmty_attributes = pmty_attributes } - -> - { - To.Parsetree.pmty_desc = - (copy_module_type_desc pmty_desc); - To.Parsetree.pmty_loc = (copy_location pmty_loc); - To.Parsetree.pmty_attributes = - (copy_attributes pmty_attributes) - } - -and copy_module_type_desc : - From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = - function - | From.Parsetree.Pmty_ident x0 -> - To.Parsetree.Pmty_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmty_signature x0 -> - To.Parsetree.Pmty_signature (copy_signature x0) - | From.Parsetree.Pmty_functor (x0,x1,x2) -> - To.Parsetree.Pmty_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_type x2)) - | From.Parsetree.Pmty_with (x0,x1) -> - To.Parsetree.Pmty_with - ((copy_module_type x0), - (List.map copy_with_constraint x1)) - | From.Parsetree.Pmty_typeof x0 -> - To.Parsetree.Pmty_typeof (copy_module_expr x0) - | From.Parsetree.Pmty_extension x0 -> - To.Parsetree.Pmty_extension (copy_extension x0) - | From.Parsetree.Pmty_alias x0 -> - To.Parsetree.Pmty_alias - (copy_loc copy_longident x0) - -and copy_with_constraint : - From.Parsetree.with_constraint -> To.Parsetree.with_constraint = - function - | From.Parsetree.Pwith_type (x0,x1) -> - To.Parsetree.Pwith_type - ((copy_loc copy_longident x0), - (copy_type_declaration x1)) - | From.Parsetree.Pwith_module (x0,x1) -> - To.Parsetree.Pwith_module - ((copy_loc copy_longident x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pwith_typesubst ({ txt = Longident.Lident _; _ }, x0) -> - To.Parsetree.Pwith_typesubst - (copy_type_declaration x0) - | From.Parsetree.Pwith_modsubst ({ txt = Longident.Lident x0; loc },x1) -> - To.Parsetree.Pwith_modsubst - ({ txt = x0; loc }, (copy_loc copy_longident x1)) - | From.Parsetree.Pwith_typesubst ({ loc; _ }, _x0) -> - migration_error loc Pwith_typesubst_longident - | From.Parsetree.Pwith_modsubst ({ loc; _ },_x1) -> - migration_error loc Pwith_modsubst_longident - -and copy_signature : - From.Parsetree.signature -> To.Parsetree.signature = - fun x -> List.map copy_signature_item x - -and copy_signature_item : - From.Parsetree.signature_item -> To.Parsetree.signature_item = - fun - { From.Parsetree.psig_desc = psig_desc; - From.Parsetree.psig_loc = psig_loc } - -> - { - To.Parsetree.psig_desc = - (copy_signature_item_desc psig_desc); - To.Parsetree.psig_loc = (copy_location psig_loc) - } - -and copy_signature_item_desc : - From.Parsetree.signature_item_desc -> - To.Parsetree.signature_item_desc - = - function - | From.Parsetree.Psig_value x0 -> - To.Parsetree.Psig_value - (copy_value_description x0) - | From.Parsetree.Psig_type (x0,x1) -> - To.Parsetree.Psig_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Psig_typext x0 -> - To.Parsetree.Psig_typext - (copy_type_extension x0) - | From.Parsetree.Psig_exception x0 -> - To.Parsetree.Psig_exception - (copy_extension_constructor x0) - | From.Parsetree.Psig_module x0 -> - To.Parsetree.Psig_module - (copy_module_declaration x0) - | From.Parsetree.Psig_recmodule x0 -> - To.Parsetree.Psig_recmodule - (List.map copy_module_declaration x0) - | From.Parsetree.Psig_modtype x0 -> - To.Parsetree.Psig_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Psig_open x0 -> - To.Parsetree.Psig_open - (copy_open_description x0) - | From.Parsetree.Psig_include x0 -> - To.Parsetree.Psig_include - (copy_include_description x0) - | From.Parsetree.Psig_class x0 -> - To.Parsetree.Psig_class - (List.map copy_class_description x0) - | From.Parsetree.Psig_class_type x0 -> - To.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Psig_attribute x0 -> - To.Parsetree.Psig_attribute (copy_attribute x0) - | From.Parsetree.Psig_extension (x0,x1) -> - To.Parsetree.Psig_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_class_type_declaration : - From.Parsetree.class_type_declaration -> - To.Parsetree.class_type_declaration - = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_description : - From.Parsetree.class_description -> To.Parsetree.class_description - = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_type : - From.Parsetree.class_type -> To.Parsetree.class_type = - fun - { From.Parsetree.pcty_desc = pcty_desc; - From.Parsetree.pcty_loc = pcty_loc; - From.Parsetree.pcty_attributes = pcty_attributes } - -> - { - To.Parsetree.pcty_desc = - (copy_class_type_desc pcty_desc); - To.Parsetree.pcty_loc = (copy_location pcty_loc); - To.Parsetree.pcty_attributes = - (copy_attributes pcty_attributes) - } - -and copy_class_type_desc : - From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = - function - | From.Parsetree.Pcty_constr (x0,x1) -> - To.Parsetree.Pcty_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcty_signature x0 -> - To.Parsetree.Pcty_signature - (copy_class_signature x0) - | From.Parsetree.Pcty_arrow (x0,x1,x2) -> - To.Parsetree.Pcty_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_class_type x2)) - | From.Parsetree.Pcty_extension x0 -> - To.Parsetree.Pcty_extension (copy_extension x0) - | From.Parsetree.Pcty_open (_, loc, _) -> - migration_error loc.From.Location.loc Def.Pcty_open - -and copy_class_signature : - From.Parsetree.class_signature -> To.Parsetree.class_signature = - fun - { From.Parsetree.pcsig_self = pcsig_self; - From.Parsetree.pcsig_fields = pcsig_fields } - -> - { - To.Parsetree.pcsig_self = - (copy_core_type pcsig_self); - To.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } - -and copy_class_type_field : - From.Parsetree.class_type_field -> To.Parsetree.class_type_field = - fun - { From.Parsetree.pctf_desc = pctf_desc; - From.Parsetree.pctf_loc = pctf_loc; - From.Parsetree.pctf_attributes = pctf_attributes } - -> - { - To.Parsetree.pctf_desc = - (copy_class_type_field_desc pctf_desc); - To.Parsetree.pctf_loc = (copy_location pctf_loc); - To.Parsetree.pctf_attributes = - (copy_attributes pctf_attributes) - } - -and copy_class_type_field_desc : - From.Parsetree.class_type_field_desc -> - To.Parsetree.class_type_field_desc - = - function - | From.Parsetree.Pctf_inherit x0 -> - To.Parsetree.Pctf_inherit (copy_class_type x0) - | From.Parsetree.Pctf_val x0 -> - To.Parsetree.Pctf_val - (let (x0,x1,x2,x3) = x0 in - (copy_loc (fun x -> x) x0, (copy_mutable_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_method x0 -> - To.Parsetree.Pctf_method - (let (x0,x1,x2,x3) = x0 in - (copy_loc (fun x -> x) x0, (copy_private_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_constraint x0 -> - To.Parsetree.Pctf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pctf_attribute x0 -> - To.Parsetree.Pctf_attribute (copy_attribute x0) - | From.Parsetree.Pctf_extension x0 -> - To.Parsetree.Pctf_extension (copy_extension x0) - -and copy_extension : - From.Parsetree.extension -> To.Parsetree.extension = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.class_infos -> 'g0 To.Parsetree.class_infos - = - fun f0 -> - fun - { From.Parsetree.pci_virt = pci_virt; - From.Parsetree.pci_params = pci_params; - From.Parsetree.pci_name = pci_name; - From.Parsetree.pci_expr = pci_expr; - From.Parsetree.pci_loc = pci_loc; - From.Parsetree.pci_attributes = pci_attributes } - -> - { - To.Parsetree.pci_virt = - (copy_virtual_flag pci_virt); - To.Parsetree.pci_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) pci_params); - To.Parsetree.pci_name = - (copy_loc (fun x -> x) pci_name); - To.Parsetree.pci_expr = (f0 pci_expr); - To.Parsetree.pci_loc = (copy_location pci_loc); - To.Parsetree.pci_attributes = - (copy_attributes pci_attributes) - } - -and copy_virtual_flag : - From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = - function - | From.Asttypes.Virtual -> To.Asttypes.Virtual - | From.Asttypes.Concrete -> To.Asttypes.Concrete - -and copy_include_description : - From.Parsetree.include_description -> - To.Parsetree.include_description - = - fun x -> - copy_include_infos copy_module_type x - -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.include_infos -> - 'g0 To.Parsetree.include_infos - = - fun f0 -> - fun - { From.Parsetree.pincl_mod = pincl_mod; - From.Parsetree.pincl_loc = pincl_loc; - From.Parsetree.pincl_attributes = pincl_attributes } - -> - { - To.Parsetree.pincl_mod = (f0 pincl_mod); - To.Parsetree.pincl_loc = (copy_location pincl_loc); - To.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } - -and copy_open_description : - From.Parsetree.open_description -> To.Parsetree.open_description = - fun - { From.Parsetree.popen_lid = popen_lid; - From.Parsetree.popen_override = popen_override; - From.Parsetree.popen_loc = popen_loc; - From.Parsetree.popen_attributes = popen_attributes } - -> - { - To.Parsetree.popen_lid = - (copy_loc copy_longident popen_lid); - To.Parsetree.popen_override = - (copy_override_flag popen_override); - To.Parsetree.popen_loc = (copy_location popen_loc); - To.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } - -and copy_override_flag : - From.Asttypes.override_flag -> To.Asttypes.override_flag = - function - | From.Asttypes.Override -> To.Asttypes.Override - | From.Asttypes.Fresh -> To.Asttypes.Fresh - -and copy_module_type_declaration : - From.Parsetree.module_type_declaration -> - To.Parsetree.module_type_declaration +let rec copy_out_type_extension : + Ast_406.Outcometree.out_type_extension -> + Ast_405.Outcometree.out_type_extension = fun - { From.Parsetree.pmtd_name = pmtd_name; - From.Parsetree.pmtd_type = pmtd_type; - From.Parsetree.pmtd_attributes = pmtd_attributes; - From.Parsetree.pmtd_loc = pmtd_loc } - -> + { Ast_406.Outcometree.otyext_name = otyext_name; + Ast_406.Outcometree.otyext_params = otyext_params; + Ast_406.Outcometree.otyext_constructors = otyext_constructors; + Ast_406.Outcometree.otyext_private = otyext_private } + -> { - To.Parsetree.pmtd_name = - (copy_loc (fun x -> x) pmtd_name); - To.Parsetree.pmtd_type = - (copy_option copy_module_type pmtd_type); - To.Parsetree.pmtd_attributes = - (copy_attributes pmtd_attributes); - To.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } - -and copy_module_declaration : - From.Parsetree.module_declaration -> - To.Parsetree.module_declaration - = - fun - { From.Parsetree.pmd_name = pmd_name; - From.Parsetree.pmd_type = pmd_type; - From.Parsetree.pmd_attributes = pmd_attributes; - From.Parsetree.pmd_loc = pmd_loc } - -> - { - To.Parsetree.pmd_name = - (copy_loc (fun x -> x) pmd_name); - To.Parsetree.pmd_type = - (copy_module_type pmd_type); - To.Parsetree.pmd_attributes = - (copy_attributes pmd_attributes); - To.Parsetree.pmd_loc = (copy_location pmd_loc) - } - -and copy_type_extension : - From.Parsetree.type_extension -> To.Parsetree.type_extension = - fun - { From.Parsetree.ptyext_path = ptyext_path; - From.Parsetree.ptyext_params = ptyext_params; - From.Parsetree.ptyext_constructors = ptyext_constructors; - From.Parsetree.ptyext_private = ptyext_private; - From.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - To.Parsetree.ptyext_path = - (copy_loc copy_longident ptyext_path); - To.Parsetree.ptyext_params = + Ast_405.Outcometree.otyext_name = otyext_name; + Ast_405.Outcometree.otyext_params = + (List.map (fun x -> x) otyext_params); + Ast_405.Outcometree.otyext_constructors = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptyext_params); - To.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor - ptyext_constructors); - To.Parsetree.ptyext_private = - (copy_private_flag ptyext_private); - To.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } - -and copy_extension_constructor : - From.Parsetree.extension_constructor -> - To.Parsetree.extension_constructor - = - fun - { From.Parsetree.pext_name = pext_name; - From.Parsetree.pext_kind = pext_kind; - From.Parsetree.pext_loc = pext_loc; - From.Parsetree.pext_attributes = pext_attributes } - -> - { - To.Parsetree.pext_name = - (copy_loc (fun x -> x) pext_name); - To.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - To.Parsetree.pext_loc = (copy_location pext_loc); - To.Parsetree.pext_attributes = - (copy_attributes pext_attributes) - } - -and copy_extension_constructor_kind : - From.Parsetree.extension_constructor_kind -> - To.Parsetree.extension_constructor_kind - = - function - | From.Parsetree.Pext_decl (x0,x1) -> - To.Parsetree.Pext_decl - ((copy_constructor_arguments x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pext_rebind x0 -> - To.Parsetree.Pext_rebind - (copy_loc copy_longident x0) - -and copy_type_declaration : - From.Parsetree.type_declaration -> To.Parsetree.type_declaration = - fun - { From.Parsetree.ptype_name = ptype_name; - From.Parsetree.ptype_params = ptype_params; - From.Parsetree.ptype_cstrs = ptype_cstrs; - From.Parsetree.ptype_kind = ptype_kind; - From.Parsetree.ptype_private = ptype_private; - From.Parsetree.ptype_manifest = ptype_manifest; - From.Parsetree.ptype_attributes = ptype_attributes; - From.Parsetree.ptype_loc = ptype_loc } - -> - { - To.Parsetree.ptype_name = - (copy_loc (fun x -> x) ptype_name); - To.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptype_params); - To.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0,x1,x2) = x in - ((copy_core_type x0), - (copy_core_type x1), - (copy_location x2))) ptype_cstrs); - To.Parsetree.ptype_kind = - (copy_type_kind ptype_kind); - To.Parsetree.ptype_private = - (copy_private_flag ptype_private); - To.Parsetree.ptype_manifest = - (copy_option copy_core_type ptype_manifest); - To.Parsetree.ptype_attributes = - (copy_attributes ptype_attributes); - To.Parsetree.ptype_loc = (copy_location ptype_loc) - } - -and copy_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = - function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - -and copy_type_kind : - From.Parsetree.type_kind -> To.Parsetree.type_kind = - function - | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract - | From.Parsetree.Ptype_variant x0 -> - To.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | From.Parsetree.Ptype_record x0 -> - To.Parsetree.Ptype_record - (List.map copy_label_declaration x0) - | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open - -and copy_constructor_declaration : - From.Parsetree.constructor_declaration -> - To.Parsetree.constructor_declaration - = - fun - { From.Parsetree.pcd_name = pcd_name; - From.Parsetree.pcd_args = pcd_args; - From.Parsetree.pcd_res = pcd_res; - From.Parsetree.pcd_loc = pcd_loc; - From.Parsetree.pcd_attributes = pcd_attributes } - -> - { - To.Parsetree.pcd_name = - (copy_loc (fun x -> x) pcd_name); - To.Parsetree.pcd_args = - (copy_constructor_arguments pcd_args); - To.Parsetree.pcd_res = - (copy_option copy_core_type pcd_res); - To.Parsetree.pcd_loc = (copy_location pcd_loc); - To.Parsetree.pcd_attributes = - (copy_attributes pcd_attributes) - } - -and copy_constructor_arguments : - From.Parsetree.constructor_arguments -> - To.Parsetree.constructor_arguments - = - function - | From.Parsetree.Pcstr_tuple x0 -> - To.Parsetree.Pcstr_tuple - (List.map copy_core_type x0) - | From.Parsetree.Pcstr_record x0 -> - To.Parsetree.Pcstr_record - (List.map copy_label_declaration x0) - -and copy_label_declaration : - From.Parsetree.label_declaration -> To.Parsetree.label_declaration - = - fun - { From.Parsetree.pld_name = pld_name; - From.Parsetree.pld_mutable = pld_mutable; - From.Parsetree.pld_type = pld_type; - From.Parsetree.pld_loc = pld_loc; - From.Parsetree.pld_attributes = pld_attributes } - -> - { - To.Parsetree.pld_name = - (copy_loc (fun x -> x) pld_name); - To.Parsetree.pld_mutable = - (copy_mutable_flag pld_mutable); - To.Parsetree.pld_type = - (copy_core_type pld_type); - To.Parsetree.pld_loc = (copy_location pld_loc); - To.Parsetree.pld_attributes = - (copy_attributes pld_attributes) - } - -and copy_mutable_flag : - From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = - function - | From.Asttypes.Immutable -> To.Asttypes.Immutable - | From.Asttypes.Mutable -> To.Asttypes.Mutable - -and copy_variance : - From.Asttypes.variance -> To.Asttypes.variance = - function - | From.Asttypes.Covariant -> To.Asttypes.Covariant - | From.Asttypes.Contravariant -> To.Asttypes.Contravariant - | From.Asttypes.Invariant -> To.Asttypes.Invariant - -and copy_value_description : - From.Parsetree.value_description -> To.Parsetree.value_description - = - fun - { From.Parsetree.pval_name = pval_name; - From.Parsetree.pval_type = pval_type; - From.Parsetree.pval_prim = pval_prim; - From.Parsetree.pval_attributes = pval_attributes; - From.Parsetree.pval_loc = pval_loc } - -> - { - To.Parsetree.pval_name = - (copy_loc (fun x -> x) pval_name); - To.Parsetree.pval_type = - (copy_core_type pval_type); - To.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - To.Parsetree.pval_attributes = - (copy_attributes pval_attributes); - To.Parsetree.pval_loc = (copy_location pval_loc) - } - -and copy_arg_label : - From.Asttypes.arg_label -> To.Asttypes.arg_label = - function - | From.Asttypes.Nolabel -> To.Asttypes.Nolabel - | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 - | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 - -and copy_closed_flag : - From.Asttypes.closed_flag -> To.Asttypes.closed_flag = - function - | From.Asttypes.Closed -> To.Asttypes.Closed - | From.Asttypes.Open -> To.Asttypes.Open - -and copy_label : - From.Asttypes.label -> To.Asttypes.label = fun x -> x - -and copy_rec_flag : - From.Asttypes.rec_flag -> To.Asttypes.rec_flag = - function - | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive - | From.Asttypes.Recursive -> To.Asttypes.Recursive - -and copy_constant : - From.Parsetree.constant -> To.Parsetree.constant = - function - | From.Parsetree.Pconst_integer (x0,x1) -> - To.Parsetree.Pconst_integer (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 - | From.Parsetree.Pconst_string (x0,x1) -> - To.Parsetree.Pconst_string (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_float (x0,x1) -> - To.Parsetree.Pconst_float (x0, (copy_option (fun x -> x) x1)) - -and copy_option : 'f0 'g0 . ('f0 -> 'g0) -> 'f0 option -> 'g0 option = - fun f0 -> function | None -> None | Some x0 -> Some (f0 x0) - -and copy_longident : From.Longident.t -> To.Longident.t = - function - | From.Longident.Lident x0 -> To.Longident.Lident x0 - | From.Longident.Ldot (x0,x1) -> - To.Longident.Ldot ((copy_longident x0), x1) - | From.Longident.Lapply (x0,x1) -> - To.Longident.Lapply - ((copy_longident x0), (copy_longident x1)) - -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc - = - fun f0 -> - fun { From.Asttypes.txt = txt; From.Asttypes.loc = loc } -> - { - To.Asttypes.txt = (f0 txt); - To.Asttypes.loc = (copy_location loc) - } - -and copy_location : From.Location.t -> To.Location.t = - fun - { From.Location.loc_start = loc_start; - From.Location.loc_end = loc_end; - From.Location.loc_ghost = loc_ghost } - -> - { - To.Location.loc_start = (copy_Lexing_position loc_start); - To.Location.loc_end = (copy_Lexing_position loc_end); - To.Location.loc_ghost = (copy_bool loc_ghost) - } - -and copy_bool : bool -> bool = function | false -> false | true -> true - -and copy_Lexing_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum + (fun x -> + let (x0, x1, x2) = x in + (x0, (List.map copy_out_type x1), + (Option.map copy_out_type x2))) otyext_constructors); + Ast_405.Outcometree.otyext_private = (copy_private_flag otyext_private) } - -let rec copy_out_phrase : - From.Outcometree.out_phrase -> To.Outcometree.out_phrase = +and copy_out_phrase : + Ast_406.Outcometree.out_phrase -> Ast_405.Outcometree.out_phrase = function - | From.Outcometree.Ophr_eval (x0,x1) -> - To.Outcometree.Ophr_eval - ((copy_out_value x0), - (copy_out_type x1)) - | From.Outcometree.Ophr_signature x0 -> - To.Outcometree.Ophr_signature + | Ast_406.Outcometree.Ophr_eval (x0, x1) -> + Ast_405.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1)) + | Ast_406.Outcometree.Ophr_signature x0 -> + Ast_405.Outcometree.Ophr_signature (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_sig_item x0), - (copy_option copy_out_value x1))) x0) - | From.Outcometree.Ophr_exception x0 -> - To.Outcometree.Ophr_exception - (let (x0,x1) = x0 in - ((copy_exn x0), (copy_out_value x1))) - -and copy_exn : exn -> exn = fun x -> x - + (fun x -> + let (x0, x1) = x in + ((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0) + | Ast_406.Outcometree.Ophr_exception x0 -> + Ast_405.Outcometree.Ophr_exception + (let (x0, x1) = x0 in (x0, (copy_out_value x1))) and copy_out_sig_item : - From.Outcometree.out_sig_item -> To.Outcometree.out_sig_item = + Ast_406.Outcometree.out_sig_item -> Ast_405.Outcometree.out_sig_item = function - | From.Outcometree.Osig_class (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class - ((copy_bool x0), x1, + | Ast_406.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> + Ast_405.Outcometree.Osig_class + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_class_type (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class_type - ((copy_bool x0), x1, + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_406.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> + Ast_405.Outcometree.Osig_class_type + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_typext (x0,x1) -> - To.Outcometree.Osig_typext - ((copy_out_extension_constructor x0), - (copy_out_ext_status x1)) - | From.Outcometree.Osig_modtype (x0,x1) -> - To.Outcometree.Osig_modtype - (x0, (copy_out_module_type x1)) - | From.Outcometree.Osig_module (x0,x1,x2) -> - To.Outcometree.Osig_module - (x0, (copy_out_module_type x1), - (copy_out_rec_status x2)) - | From.Outcometree.Osig_type (x0,x1) -> - To.Outcometree.Osig_type - ((copy_out_type_decl x0), - (copy_out_rec_status x1)) - | From.Outcometree.Osig_value x0 -> - To.Outcometree.Osig_value - (copy_out_val_decl x0) - | From.Outcometree.Osig_ellipsis -> To.Outcometree.Osig_ellipsis - + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_406.Outcometree.Osig_typext (x0, x1) -> + Ast_405.Outcometree.Osig_typext + ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) + | Ast_406.Outcometree.Osig_modtype (x0, x1) -> + Ast_405.Outcometree.Osig_modtype (x0, (copy_out_module_type x1)) + | Ast_406.Outcometree.Osig_module (x0, x1, x2) -> + Ast_405.Outcometree.Osig_module + (x0, (copy_out_module_type x1), (copy_out_rec_status x2)) + | Ast_406.Outcometree.Osig_type (x0, x1) -> + Ast_405.Outcometree.Osig_type + ((copy_out_type_decl x0), (copy_out_rec_status x1)) + | Ast_406.Outcometree.Osig_value x0 -> + Ast_405.Outcometree.Osig_value (copy_out_val_decl x0) + | Ast_406.Outcometree.Osig_ellipsis -> Ast_405.Outcometree.Osig_ellipsis and copy_out_val_decl : - From.Outcometree.out_val_decl -> To.Outcometree.out_val_decl = + Ast_406.Outcometree.out_val_decl -> Ast_405.Outcometree.out_val_decl = fun - { From.Outcometree.oval_name = oval_name; - From.Outcometree.oval_type = oval_type; - From.Outcometree.oval_prims = oval_prims; - From.Outcometree.oval_attributes = oval_attributes } - -> + { Ast_406.Outcometree.oval_name = oval_name; + Ast_406.Outcometree.oval_type = oval_type; + Ast_406.Outcometree.oval_prims = oval_prims; + Ast_406.Outcometree.oval_attributes = oval_attributes } + -> { - To.Outcometree.oval_name = oval_name; - To.Outcometree.oval_type = - (copy_out_type oval_type); - To.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); - To.Outcometree.oval_attributes = + Ast_405.Outcometree.oval_name = oval_name; + Ast_405.Outcometree.oval_type = (copy_out_type oval_type); + Ast_405.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); + Ast_405.Outcometree.oval_attributes = (List.map copy_out_attribute oval_attributes) } - and copy_out_type_decl : - From.Outcometree.out_type_decl -> To.Outcometree.out_type_decl = + Ast_406.Outcometree.out_type_decl -> Ast_405.Outcometree.out_type_decl = fun - { From.Outcometree.otype_name = otype_name; - From.Outcometree.otype_params = otype_params; - From.Outcometree.otype_type = otype_type; - From.Outcometree.otype_private = otype_private; - From.Outcometree.otype_immediate = otype_immediate; - From.Outcometree.otype_unboxed = otype_unboxed; - From.Outcometree.otype_cstrs = otype_cstrs } - -> + { Ast_406.Outcometree.otype_name = otype_name; + Ast_406.Outcometree.otype_params = otype_params; + Ast_406.Outcometree.otype_type = otype_type; + Ast_406.Outcometree.otype_private = otype_private; + Ast_406.Outcometree.otype_immediate = otype_immediate; + Ast_406.Outcometree.otype_unboxed = otype_unboxed; + Ast_406.Outcometree.otype_cstrs = otype_cstrs } + -> { - To.Outcometree.otype_name = otype_name; - To.Outcometree.otype_params = + Ast_405.Outcometree.otype_name = otype_name; + Ast_405.Outcometree.otype_params = (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) otype_params); - To.Outcometree.otype_type = - (copy_out_type otype_type); - To.Outcometree.otype_private = - (copy_From_Asttypes_private_flag otype_private); - To.Outcometree.otype_immediate = (copy_bool otype_immediate); - To.Outcometree.otype_unboxed = (copy_bool otype_unboxed); - To.Outcometree.otype_cstrs = + Ast_405.Outcometree.otype_type = (copy_out_type otype_type); + Ast_405.Outcometree.otype_private = (copy_private_flag otype_private); + Ast_405.Outcometree.otype_immediate = otype_immediate; + Ast_405.Outcometree.otype_unboxed = otype_unboxed; + Ast_405.Outcometree.otype_cstrs = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_type x0), - (copy_out_type x1))) otype_cstrs) + (fun x -> + let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1))) + otype_cstrs) } - and copy_out_module_type : - From.Outcometree.out_module_type -> To.Outcometree.out_module_type + Ast_406.Outcometree.out_module_type -> Ast_405.Outcometree.out_module_type = function - | From.Outcometree.Omty_abstract -> To.Outcometree.Omty_abstract - | From.Outcometree.Omty_functor (x0,x1,x2) -> - To.Outcometree.Omty_functor - (x0, (copy_option copy_out_module_type x1), - (copy_out_module_type x2)) - | From.Outcometree.Omty_ident x0 -> - To.Outcometree.Omty_ident (copy_out_ident x0) - | From.Outcometree.Omty_signature x0 -> - To.Outcometree.Omty_signature - (List.map copy_out_sig_item x0) - | From.Outcometree.Omty_alias x0 -> - To.Outcometree.Omty_alias (copy_out_ident x0) - + | Ast_406.Outcometree.Omty_abstract -> Ast_405.Outcometree.Omty_abstract + | Ast_406.Outcometree.Omty_functor (x0, x1, x2) -> + Ast_405.Outcometree.Omty_functor + (x0, (Option.map copy_out_module_type x1), (copy_out_module_type x2)) + | Ast_406.Outcometree.Omty_ident x0 -> + Ast_405.Outcometree.Omty_ident (copy_out_ident x0) + | Ast_406.Outcometree.Omty_signature x0 -> + Ast_405.Outcometree.Omty_signature (List.map copy_out_sig_item x0) + | Ast_406.Outcometree.Omty_alias x0 -> + Ast_405.Outcometree.Omty_alias (copy_out_ident x0) and copy_out_ext_status : - From.Outcometree.out_ext_status -> To.Outcometree.out_ext_status = + Ast_406.Outcometree.out_ext_status -> Ast_405.Outcometree.out_ext_status = function - | From.Outcometree.Oext_first -> To.Outcometree.Oext_first - | From.Outcometree.Oext_next -> To.Outcometree.Oext_next - | From.Outcometree.Oext_exception -> To.Outcometree.Oext_exception - + | Ast_406.Outcometree.Oext_first -> Ast_405.Outcometree.Oext_first + | Ast_406.Outcometree.Oext_next -> Ast_405.Outcometree.Oext_next + | Ast_406.Outcometree.Oext_exception -> Ast_405.Outcometree.Oext_exception and copy_out_extension_constructor : - From.Outcometree.out_extension_constructor -> - To.Outcometree.out_extension_constructor + Ast_406.Outcometree.out_extension_constructor -> + Ast_405.Outcometree.out_extension_constructor = fun - { From.Outcometree.oext_name = oext_name; - From.Outcometree.oext_type_name = oext_type_name; - From.Outcometree.oext_type_params = oext_type_params; - From.Outcometree.oext_args = oext_args; - From.Outcometree.oext_ret_type = oext_ret_type; - From.Outcometree.oext_private = oext_private } - -> + { Ast_406.Outcometree.oext_name = oext_name; + Ast_406.Outcometree.oext_type_name = oext_type_name; + Ast_406.Outcometree.oext_type_params = oext_type_params; + Ast_406.Outcometree.oext_args = oext_args; + Ast_406.Outcometree.oext_ret_type = oext_ret_type; + Ast_406.Outcometree.oext_private = oext_private } + -> { - To.Outcometree.oext_name = oext_name; - To.Outcometree.oext_type_name = oext_type_name; - To.Outcometree.oext_type_params = - (List.map (fun x -> x) oext_type_params); - To.Outcometree.oext_args = - (List.map copy_out_type oext_args); - To.Outcometree.oext_ret_type = - (copy_option copy_out_type oext_ret_type); - To.Outcometree.oext_private = - (copy_From_Asttypes_private_flag oext_private) + Ast_405.Outcometree.oext_name = oext_name; + Ast_405.Outcometree.oext_type_name = oext_type_name; + Ast_405.Outcometree.oext_type_params = + (List.map (fun x -> x) oext_type_params); + Ast_405.Outcometree.oext_args = (List.map copy_out_type oext_args); + Ast_405.Outcometree.oext_ret_type = + (Option.map copy_out_type oext_ret_type); + Ast_405.Outcometree.oext_private = (copy_private_flag oext_private) } - -and copy_From_Asttypes_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = +and copy_private_flag : + Ast_406.Asttypes.private_flag -> Ast_405.Asttypes.private_flag = function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - + | Ast_406.Asttypes.Private -> Ast_405.Asttypes.Private + | Ast_406.Asttypes.Public -> Ast_405.Asttypes.Public and copy_out_rec_status : - From.Outcometree.out_rec_status -> To.Outcometree.out_rec_status = + Ast_406.Outcometree.out_rec_status -> Ast_405.Outcometree.out_rec_status = function - | From.Outcometree.Orec_not -> To.Outcometree.Orec_not - | From.Outcometree.Orec_first -> To.Outcometree.Orec_first - | From.Outcometree.Orec_next -> To.Outcometree.Orec_next - + | Ast_406.Outcometree.Orec_not -> Ast_405.Outcometree.Orec_not + | Ast_406.Outcometree.Orec_first -> Ast_405.Outcometree.Orec_first + | Ast_406.Outcometree.Orec_next -> Ast_405.Outcometree.Orec_next and copy_out_class_type : - From.Outcometree.out_class_type -> To.Outcometree.out_class_type = - function - | From.Outcometree.Octy_constr (x0,x1) -> - To.Outcometree.Octy_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Octy_arrow (x0,x1,x2) -> - To.Outcometree.Octy_arrow - (x0, (copy_out_type x1), - (copy_out_class_type x2)) - | From.Outcometree.Octy_signature (x0,x1) -> - To.Outcometree.Octy_signature - ((copy_option copy_out_type x0), + Ast_406.Outcometree.out_class_type -> Ast_405.Outcometree.out_class_type = + function + | Ast_406.Outcometree.Octy_constr (x0, x1) -> + Ast_405.Outcometree.Octy_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_406.Outcometree.Octy_arrow (x0, x1, x2) -> + Ast_405.Outcometree.Octy_arrow + (x0, (copy_out_type x1), (copy_out_class_type x2)) + | Ast_406.Outcometree.Octy_signature (x0, x1) -> + Ast_405.Outcometree.Octy_signature + ((Option.map copy_out_type x0), (List.map copy_out_class_sig_item x1)) - and copy_out_class_sig_item : - From.Outcometree.out_class_sig_item -> - To.Outcometree.out_class_sig_item + Ast_406.Outcometree.out_class_sig_item -> + Ast_405.Outcometree.out_class_sig_item = function - | From.Outcometree.Ocsg_constraint (x0,x1) -> - To.Outcometree.Ocsg_constraint - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Ocsg_method (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_method - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - | From.Outcometree.Ocsg_value (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_value - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - + | Ast_406.Outcometree.Ocsg_constraint (x0, x1) -> + Ast_405.Outcometree.Ocsg_constraint + ((copy_out_type x0), (copy_out_type x1)) + | Ast_406.Outcometree.Ocsg_method (x0, x1, x2, x3) -> + Ast_405.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3)) + | Ast_406.Outcometree.Ocsg_value (x0, x1, x2, x3) -> + Ast_405.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3)) and copy_out_type : - From.Outcometree.out_type -> To.Outcometree.out_type = - function - | From.Outcometree.Otyp_abstract -> To.Outcometree.Otyp_abstract - | From.Outcometree.Otyp_open -> To.Outcometree.Otyp_open - | From.Outcometree.Otyp_alias (x0,x1) -> - To.Outcometree.Otyp_alias - ((copy_out_type x0), x1) - | From.Outcometree.Otyp_arrow (x0,x1,x2) -> - To.Outcometree.Otyp_arrow - (x0, (copy_out_type x1), - (copy_out_type x2)) - | From.Outcometree.Otyp_class (x0,x1,x2) -> - To.Outcometree.Otyp_class - ((copy_bool x0), (copy_out_ident x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_constr (x0,x1) -> - To.Outcometree.Otyp_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Otyp_manifest (x0,x1) -> - To.Outcometree.Otyp_manifest - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Otyp_object (x0,x1) -> - To.Outcometree.Otyp_object - ((List.map - (fun x -> - let (x0,x1) = x in - (x0, (copy_out_type x1))) x0), - (copy_option copy_bool x1)) - | From.Outcometree.Otyp_record x0 -> - To.Outcometree.Otyp_record + Ast_406.Outcometree.out_type -> Ast_405.Outcometree.out_type = + function + | Ast_406.Outcometree.Otyp_abstract -> Ast_405.Outcometree.Otyp_abstract + | Ast_406.Outcometree.Otyp_open -> Ast_405.Outcometree.Otyp_open + | Ast_406.Outcometree.Otyp_alias (x0, x1) -> + Ast_405.Outcometree.Otyp_alias ((copy_out_type x0), x1) + | Ast_406.Outcometree.Otyp_arrow (x0, x1, x2) -> + Ast_405.Outcometree.Otyp_arrow + (x0, (copy_out_type x1), (copy_out_type x2)) + | Ast_406.Outcometree.Otyp_class (x0, x1, x2) -> + Ast_405.Outcometree.Otyp_class + (x0, (copy_out_ident x1), (List.map copy_out_type x2)) + | Ast_406.Outcometree.Otyp_constr (x0, x1) -> + Ast_405.Outcometree.Otyp_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_406.Outcometree.Otyp_manifest (x0, x1) -> + Ast_405.Outcometree.Otyp_manifest + ((copy_out_type x0), (copy_out_type x1)) + | Ast_406.Outcometree.Otyp_object (x0, x1) -> + Ast_405.Outcometree.Otyp_object + ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0), + (Option.map (fun x -> x) x1)) + | Ast_406.Outcometree.Otyp_record x0 -> + Ast_405.Outcometree.Otyp_record (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), (copy_out_type x2))) - x0) - | From.Outcometree.Otyp_stuff x0 -> To.Outcometree.Otyp_stuff x0 - | From.Outcometree.Otyp_sum x0 -> - To.Outcometree.Otyp_sum + (fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0) + | Ast_406.Outcometree.Otyp_stuff x0 -> Ast_405.Outcometree.Otyp_stuff x0 + | Ast_406.Outcometree.Otyp_sum x0 -> + Ast_405.Outcometree.Otyp_sum (List.map - (fun x -> - let (x0,x1,x2) = x in + (fun x -> + let (x0, x1, x2) = x in (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) x0) - | From.Outcometree.Otyp_tuple x0 -> - To.Outcometree.Otyp_tuple - (List.map copy_out_type x0) - | From.Outcometree.Otyp_var (x0,x1) -> - To.Outcometree.Otyp_var ((copy_bool x0), x1) - | From.Outcometree.Otyp_variant (x0,x1,x2,x3) -> - To.Outcometree.Otyp_variant - ((copy_bool x0), (copy_out_variant x1), - (copy_bool x2), - (copy_option (fun x -> List.map (fun x -> x) x) x3)) - | From.Outcometree.Otyp_poly (x0,x1) -> - To.Outcometree.Otyp_poly - ((List.map (fun x -> x) x0), (copy_out_type x1)) - | From.Outcometree.Otyp_module (x0,x1,x2) -> - To.Outcometree.Otyp_module - (x0, (List.map (fun x -> x) x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_attribute (x0,x1) -> - To.Outcometree.Otyp_attribute - ((copy_out_type x0), - (copy_out_attribute x1)) - + (Option.map copy_out_type x2))) x0) + | Ast_406.Outcometree.Otyp_tuple x0 -> + Ast_405.Outcometree.Otyp_tuple (List.map copy_out_type x0) + | Ast_406.Outcometree.Otyp_var (x0, x1) -> + Ast_405.Outcometree.Otyp_var (x0, x1) + | Ast_406.Outcometree.Otyp_variant (x0, x1, x2, x3) -> + Ast_405.Outcometree.Otyp_variant + (x0, (copy_out_variant x1), x2, + (Option.map (fun x -> List.map (fun x -> x) x) x3)) + | Ast_406.Outcometree.Otyp_poly (x0, x1) -> + Ast_405.Outcometree.Otyp_poly + ((List.map (fun x -> x) x0), (copy_out_type x1)) + | Ast_406.Outcometree.Otyp_module (x0, x1, x2) -> + Ast_405.Outcometree.Otyp_module + (x0, (List.map (fun x -> x) x1), (List.map copy_out_type x2)) + | Ast_406.Outcometree.Otyp_attribute (x0, x1) -> + Ast_405.Outcometree.Otyp_attribute + ((copy_out_type x0), (copy_out_attribute x1)) and copy_out_attribute : - From.Outcometree.out_attribute -> To.Outcometree.out_attribute = - fun { From.Outcometree.oattr_name = oattr_name } -> - { To.Outcometree.oattr_name = oattr_name } - + Ast_406.Outcometree.out_attribute -> Ast_405.Outcometree.out_attribute = + fun { Ast_406.Outcometree.oattr_name = oattr_name } -> + { Ast_405.Outcometree.oattr_name = oattr_name } and copy_out_variant : - From.Outcometree.out_variant -> To.Outcometree.out_variant = + Ast_406.Outcometree.out_variant -> Ast_405.Outcometree.out_variant = function - | From.Outcometree.Ovar_fields x0 -> - To.Outcometree.Ovar_fields + | Ast_406.Outcometree.Ovar_fields x0 -> + Ast_405.Outcometree.Ovar_fields (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), - (List.map copy_out_type x2))) x0) - | From.Outcometree.Ovar_typ x0 -> - To.Outcometree.Ovar_typ (copy_out_type x0) - + (fun x -> + let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2))) + x0) + | Ast_406.Outcometree.Ovar_typ x0 -> + Ast_405.Outcometree.Ovar_typ (copy_out_type x0) and copy_out_value : - From.Outcometree.out_value -> To.Outcometree.out_value = - function - | From.Outcometree.Oval_array x0 -> - To.Outcometree.Oval_array - (List.map copy_out_value x0) - | From.Outcometree.Oval_char x0 -> To.Outcometree.Oval_char x0 - | From.Outcometree.Oval_constr (x0,x1) -> - To.Outcometree.Oval_constr - ((copy_out_ident x0), - (List.map copy_out_value x1)) - | From.Outcometree.Oval_ellipsis -> To.Outcometree.Oval_ellipsis - | From.Outcometree.Oval_float x0 -> - To.Outcometree.Oval_float (copy_float x0) - | From.Outcometree.Oval_int x0 -> To.Outcometree.Oval_int x0 - | From.Outcometree.Oval_int32 x0 -> To.Outcometree.Oval_int32 x0 - | From.Outcometree.Oval_int64 x0 -> To.Outcometree.Oval_int64 x0 - | From.Outcometree.Oval_nativeint x0 -> - To.Outcometree.Oval_nativeint x0 - | From.Outcometree.Oval_list x0 -> - To.Outcometree.Oval_list - (List.map copy_out_value x0) - | From.Outcometree.Oval_printer x0 -> - To.Outcometree.Oval_printer x0 - | From.Outcometree.Oval_record x0 -> - To.Outcometree.Oval_record + Ast_406.Outcometree.out_value -> Ast_405.Outcometree.out_value = + function + | Ast_406.Outcometree.Oval_array x0 -> + Ast_405.Outcometree.Oval_array (List.map copy_out_value x0) + | Ast_406.Outcometree.Oval_char x0 -> Ast_405.Outcometree.Oval_char x0 + | Ast_406.Outcometree.Oval_constr (x0, x1) -> + Ast_405.Outcometree.Oval_constr + ((copy_out_ident x0), (List.map copy_out_value x1)) + | Ast_406.Outcometree.Oval_ellipsis -> Ast_405.Outcometree.Oval_ellipsis + | Ast_406.Outcometree.Oval_float x0 -> Ast_405.Outcometree.Oval_float x0 + | Ast_406.Outcometree.Oval_int x0 -> Ast_405.Outcometree.Oval_int x0 + | Ast_406.Outcometree.Oval_int32 x0 -> Ast_405.Outcometree.Oval_int32 x0 + | Ast_406.Outcometree.Oval_int64 x0 -> Ast_405.Outcometree.Oval_int64 x0 + | Ast_406.Outcometree.Oval_nativeint x0 -> + Ast_405.Outcometree.Oval_nativeint x0 + | Ast_406.Outcometree.Oval_list x0 -> + Ast_405.Outcometree.Oval_list (List.map copy_out_value x0) + | Ast_406.Outcometree.Oval_printer x0 -> + Ast_405.Outcometree.Oval_printer x0 + | Ast_406.Outcometree.Oval_record x0 -> + Ast_405.Outcometree.Oval_record (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_ident x0), - (copy_out_value x1))) x0) - | From.Outcometree.Oval_string (x0, _, _) -> To.Outcometree.Oval_string x0 - | From.Outcometree.Oval_stuff x0 -> To.Outcometree.Oval_stuff x0 - | From.Outcometree.Oval_tuple x0 -> - To.Outcometree.Oval_tuple - (List.map copy_out_value x0) - | From.Outcometree.Oval_variant (x0,x1) -> - To.Outcometree.Oval_variant - (x0, (copy_option copy_out_value x1)) - -and copy_float : float -> float = fun x -> x - + (fun x -> + let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1))) + x0) + | Ast_406.Outcometree.Oval_string (x0, _, _) -> + Ast_405.Outcometree.Oval_string x0 + | Ast_406.Outcometree.Oval_stuff x0 -> Ast_405.Outcometree.Oval_stuff x0 + | Ast_406.Outcometree.Oval_tuple x0 -> + Ast_405.Outcometree.Oval_tuple (List.map copy_out_value x0) + | Ast_406.Outcometree.Oval_variant (x0, x1) -> + Ast_405.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1)) and copy_out_ident : - From.Outcometree.out_ident -> To.Outcometree.out_ident = - function - | From.Outcometree.Oide_apply (x0,x1) -> - To.Outcometree.Oide_apply - ((copy_out_ident x0), - (copy_out_ident x1)) - | From.Outcometree.Oide_dot (x0,x1) -> - To.Outcometree.Oide_dot - ((copy_out_ident x0), x1) - | From.Outcometree.Oide_ident x0 -> To.Outcometree.Oide_ident x0 - -let rec copy_toplevel_phrase : - From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = - function - | From.Parsetree.Ptop_def x0 -> - To.Parsetree.Ptop_def (copy_structure x0) - | From.Parsetree.Ptop_dir (x0,x1) -> - To.Parsetree.Ptop_dir - (x0, (copy_directive_argument x1)) - -and copy_directive_argument : - From.Parsetree.directive_argument -> To.Parsetree.directive_argument = - function - | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none - | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 - | From.Parsetree.Pdir_int (x0,x1) -> - To.Parsetree.Pdir_int (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pdir_ident x0 -> - To.Parsetree.Pdir_ident (copy_longident x0) - | From.Parsetree.Pdir_bool x0 -> - To.Parsetree.Pdir_bool (copy_bool x0) - -let copy_out_type_extension : - From.Outcometree.out_type_extension -> To.Outcometree.out_type_extension = - fun - { From.Outcometree.otyext_name = otyext_name; - From.Outcometree.otyext_params = otyext_params; - From.Outcometree.otyext_constructors = otyext_constructors; - From.Outcometree.otyext_private = otyext_private } - -> - { - To.Outcometree.otyext_name = otyext_name; - To.Outcometree.otyext_params = - (List.map (fun x -> x) otyext_params); - To.Outcometree.otyext_constructors = - (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) - otyext_constructors); - To.Outcometree.otyext_private = - (copy_private_flag otyext_private) - } - -let copy_cases x = List.map copy_case x -let copy_pat = copy_pattern -let copy_expr = copy_expression -let copy_typ = copy_core_type + Ast_406.Outcometree.out_ident -> Ast_405.Outcometree.out_ident = + function + | Ast_406.Outcometree.Oide_apply (x0, x1) -> + Ast_405.Outcometree.Oide_apply + ((copy_out_ident x0), (copy_out_ident x1)) + | Ast_406.Outcometree.Oide_dot (x0, x1) -> + Ast_405.Outcometree.Oide_dot ((copy_out_ident x0), x1) + | Ast_406.Outcometree.Oide_ident x0 -> Ast_405.Outcometree.Oide_ident x0 diff --git a/src/vendored-omp/src/migrate_parsetree_406_407.ml b/src/vendored-omp/src/migrate_parsetree_406_407.ml index 3159e5ce5..1c4ba0ae6 100644 --- a/src/vendored-omp/src/migrate_parsetree_406_407.ml +++ b/src/vendored-omp/src/migrate_parsetree_406_407.ml @@ -15,116 +15,3 @@ include Migrate_parsetree_406_407_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - (*$*) - } as mapper) -> - let module R = Migrate_parsetree_407_406_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_406_407_migrate.ml b/src/vendored-omp/src/migrate_parsetree_406_407_migrate.ml index f96ed71eb..482fe73bf 100644 --- a/src/vendored-omp/src/migrate_parsetree_406_407_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_406_407_migrate.ml @@ -1,1734 +1,305 @@ -(**************************************************************************) -(* *) -(* OCaml Migrate Parsetree *) -(* *) -(* Frédéric Bour *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2017 Institut National de Recherche en Informatique et *) -(* en Automatique (INRIA). *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -module Def = Migrate_parsetree_def +open Stdlib0 module From = Ast_406 module To = Ast_407 - -let migration_error location feature = - raise (Def.Migration_error (feature, location)) - -let rec copy_expression : - From.Parsetree.expression -> To.Parsetree.expression = - fun - { From.Parsetree.pexp_desc = pexp_desc; - From.Parsetree.pexp_loc = pexp_loc; - From.Parsetree.pexp_attributes = pexp_attributes } - -> - { - To.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - To.Parsetree.pexp_loc = (copy_location pexp_loc); - To.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } - -and copy_expression_desc : - From.Parsetree.expression_desc -> To.Parsetree.expression_desc = - function - | From.Parsetree.Pexp_ident x0 -> - To.Parsetree.Pexp_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_constant x0 -> - To.Parsetree.Pexp_constant (copy_constant x0) - | From.Parsetree.Pexp_let (x0,x1,x2) -> - To.Parsetree.Pexp_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_expression x2)) - | From.Parsetree.Pexp_function x0 -> - To.Parsetree.Pexp_function - (List.map copy_case x0) - | From.Parsetree.Pexp_fun (x0,x1,x2,x3) -> - To.Parsetree.Pexp_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_expression x3)) - | From.Parsetree.Pexp_apply (x0,x1) -> - To.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pexp_match (x0,x1) -> - To.Parsetree.Pexp_match - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_try (x0,x1) -> - To.Parsetree.Pexp_try - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_tuple x0 -> - To.Parsetree.Pexp_tuple - (List.map copy_expression x0) - | From.Parsetree.Pexp_construct (x0,x1) -> - To.Parsetree.Pexp_construct - ((copy_loc copy_longident x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_variant (x0,x1) -> - To.Parsetree.Pexp_variant - ((copy_label x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_record (x0,x1) -> - To.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_expression x1))) x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_field (x0,x1) -> - To.Parsetree.Pexp_field - ((copy_expression x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pexp_setfield (x0,x1,x2) -> - To.Parsetree.Pexp_setfield - ((copy_expression x0), - (copy_loc copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_array x0 -> - To.Parsetree.Pexp_array - (List.map copy_expression x0) - | From.Parsetree.Pexp_ifthenelse (x0,x1,x2) -> - To.Parsetree.Pexp_ifthenelse - ((copy_expression x0), - (copy_expression x1), - (copy_option copy_expression x2)) - | From.Parsetree.Pexp_sequence (x0,x1) -> - To.Parsetree.Pexp_sequence - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_while (x0,x1) -> - To.Parsetree.Pexp_while - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_for (x0,x1,x2,x3,x4) -> - To.Parsetree.Pexp_for - ((copy_pattern x0), - (copy_expression x1), - (copy_expression x2), - (copy_direction_flag x3), - (copy_expression x4)) - | From.Parsetree.Pexp_constraint (x0,x1) -> - To.Parsetree.Pexp_constraint - ((copy_expression x0), - (copy_core_type x1)) - | From.Parsetree.Pexp_coerce (x0,x1,x2) -> - To.Parsetree.Pexp_coerce - ((copy_expression x0), - (copy_option copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Pexp_send (x0,x1) -> - To.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc (fun x -> x) x1)) - | From.Parsetree.Pexp_new x0 -> - To.Parsetree.Pexp_new - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_setinstvar (x0,x1) -> - To.Parsetree.Pexp_setinstvar - ((copy_loc (fun x -> x) x0), - (copy_expression x1)) - | From.Parsetree.Pexp_override x0 -> - To.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_expression x1))) x0) - | From.Parsetree.Pexp_letmodule (x0,x1,x2) -> - To.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> x) x0), - (copy_module_expr x1), - (copy_expression x2)) - | From.Parsetree.Pexp_letexception (x0,x1) -> - To.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), - (copy_expression x1)) - | From.Parsetree.Pexp_assert x0 -> - To.Parsetree.Pexp_assert (copy_expression x0) - | From.Parsetree.Pexp_lazy x0 -> - To.Parsetree.Pexp_lazy (copy_expression x0) - | From.Parsetree.Pexp_poly (x0,x1) -> - To.Parsetree.Pexp_poly - ((copy_expression x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pexp_object x0 -> - To.Parsetree.Pexp_object - (copy_class_structure x0) - | From.Parsetree.Pexp_newtype (x0,x1) -> - To.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | From.Parsetree.Pexp_pack x0 -> - To.Parsetree.Pexp_pack (copy_module_expr x0) - | From.Parsetree.Pexp_open (x0,x1,x2) -> - To.Parsetree.Pexp_open - ((copy_override_flag x0), - (copy_loc copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_extension x0 -> - To.Parsetree.Pexp_extension (copy_extension x0) - | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable - -and copy_direction_flag : - From.Asttypes.direction_flag -> To.Asttypes.direction_flag = - function - | From.Asttypes.Upto -> To.Asttypes.Upto - | From.Asttypes.Downto -> To.Asttypes.Downto - -and copy_case : - From.Parsetree.case -> To.Parsetree.case = - fun - { From.Parsetree.pc_lhs = pc_lhs; - From.Parsetree.pc_guard = pc_guard; - From.Parsetree.pc_rhs = pc_rhs } - -> - { - To.Parsetree.pc_lhs = (copy_pattern pc_lhs); - To.Parsetree.pc_guard = - (copy_option copy_expression pc_guard); - To.Parsetree.pc_rhs = (copy_expression pc_rhs) - } - -and copy_value_binding : - From.Parsetree.value_binding -> To.Parsetree.value_binding = - fun - { From.Parsetree.pvb_pat = pvb_pat; - From.Parsetree.pvb_expr = pvb_expr; - From.Parsetree.pvb_attributes = pvb_attributes; - From.Parsetree.pvb_loc = pvb_loc } - -> - { - To.Parsetree.pvb_pat = (copy_pattern pvb_pat); - To.Parsetree.pvb_expr = - (copy_expression pvb_expr); - To.Parsetree.pvb_attributes = - (copy_attributes pvb_attributes); - To.Parsetree.pvb_loc = (copy_location pvb_loc) - } - -and copy_pattern : - From.Parsetree.pattern -> To.Parsetree.pattern = - fun - { From.Parsetree.ppat_desc = ppat_desc; - From.Parsetree.ppat_loc = ppat_loc; - From.Parsetree.ppat_attributes = ppat_attributes } - -> - { - To.Parsetree.ppat_desc = - (copy_pattern_desc ppat_desc); - To.Parsetree.ppat_loc = (copy_location ppat_loc); - To.Parsetree.ppat_attributes = - (copy_attributes ppat_attributes) - } - -and copy_pattern_desc : - From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc = - function - | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any - | From.Parsetree.Ppat_var x0 -> - To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_alias (x0,x1) -> - To.Parsetree.Ppat_alias - ((copy_pattern x0), - (copy_loc (fun x -> x) x1)) - | From.Parsetree.Ppat_constant x0 -> - To.Parsetree.Ppat_constant (copy_constant x0) - | From.Parsetree.Ppat_interval (x0,x1) -> - To.Parsetree.Ppat_interval - ((copy_constant x0), - (copy_constant x1)) - | From.Parsetree.Ppat_tuple x0 -> - To.Parsetree.Ppat_tuple - (List.map copy_pattern x0) - | From.Parsetree.Ppat_construct (x0,x1) -> - To.Parsetree.Ppat_construct - ((copy_loc copy_longident x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_variant (x0,x1) -> - To.Parsetree.Ppat_variant - ((copy_label x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_record (x0,x1) -> - To.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ppat_array x0 -> - To.Parsetree.Ppat_array - (List.map copy_pattern x0) - | From.Parsetree.Ppat_or (x0,x1) -> - To.Parsetree.Ppat_or - ((copy_pattern x0), - (copy_pattern x1)) - | From.Parsetree.Ppat_constraint (x0,x1) -> - To.Parsetree.Ppat_constraint - ((copy_pattern x0), - (copy_core_type x1)) - | From.Parsetree.Ppat_type x0 -> - To.Parsetree.Ppat_type - (copy_loc copy_longident x0) - | From.Parsetree.Ppat_lazy x0 -> - To.Parsetree.Ppat_lazy (copy_pattern x0) - | From.Parsetree.Ppat_unpack x0 -> - To.Parsetree.Ppat_unpack - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_exception x0 -> - To.Parsetree.Ppat_exception (copy_pattern x0) - | From.Parsetree.Ppat_extension x0 -> - To.Parsetree.Ppat_extension (copy_extension x0) - | From.Parsetree.Ppat_open (x0,x1) -> - To.Parsetree.Ppat_open - ((copy_loc copy_longident x0), - (copy_pattern x1)) - -and copy_core_type : - From.Parsetree.core_type -> To.Parsetree.core_type = - fun - { From.Parsetree.ptyp_desc = ptyp_desc; - From.Parsetree.ptyp_loc = ptyp_loc; - From.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - To.Parsetree.ptyp_desc = - (copy_core_type_desc ptyp_desc); - To.Parsetree.ptyp_loc = (copy_location ptyp_loc); - To.Parsetree.ptyp_attributes = - (copy_attributes ptyp_attributes) - } - -and copy_core_type_desc : - From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = - function - | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any - | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 - | From.Parsetree.Ptyp_arrow (x0,x1,x2) -> - To.Parsetree.Ptyp_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Ptyp_tuple x0 -> - To.Parsetree.Ptyp_tuple - (List.map copy_core_type x0) - | From.Parsetree.Ptyp_constr (x0,x1) -> - To.Parsetree.Ptyp_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_object (x0,x1) -> - To.Parsetree.Ptyp_object - (List.map copy_object_field x0, - copy_closed_flag x1) - | From.Parsetree.Ptyp_class (x0,x1) -> - To.Parsetree.Ptyp_class - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_alias (x0,x1) -> - To.Parsetree.Ptyp_alias - ((copy_core_type x0), x1) - | From.Parsetree.Ptyp_variant (x0,x1,x2) -> - To.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), - (copy_closed_flag x1), - (copy_option (fun x -> List.map copy_label x) x2)) - | From.Parsetree.Ptyp_poly (x0,x1) -> - To.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), (copy_core_type x1)) - | From.Parsetree.Ptyp_package x0 -> - To.Parsetree.Ptyp_package (copy_package_type x0) - | From.Parsetree.Ptyp_extension x0 -> - To.Parsetree.Ptyp_extension (copy_extension x0) - -and copy_package_type : - From.Parsetree.package_type -> To.Parsetree.package_type = - fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_core_type x1))) x1)) - -and copy_row_field : - From.Parsetree.row_field -> To.Parsetree.row_field = - function - | From.Parsetree.Rtag (x0,x1,x2,x3) -> - To.Parsetree.Rtag - (copy_loc copy_label x0, - copy_attributes x1, copy_bool x2, - List.map copy_core_type x3) - | From.Parsetree.Rinherit x0 -> - To.Parsetree.Rinherit (copy_core_type x0) - -and copy_object_field : - From.Parsetree.object_field -> To.Parsetree.object_field = - function - | From.Parsetree.Otag (x0,x1,x2) -> - To.Parsetree.Otag (copy_loc (fun x -> x) x0, - copy_attributes x1, - copy_core_type x2) - | From.Parsetree.Oinherit x -> To.Parsetree.Oinherit (copy_core_type x) - -and copy_attributes : - From.Parsetree.attributes -> To.Parsetree.attributes = - fun x -> List.map copy_attribute x - -and copy_attribute : - From.Parsetree.attribute -> To.Parsetree.attribute = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_payload : - From.Parsetree.payload -> To.Parsetree.payload = - function - | From.Parsetree.PStr x0 -> - To.Parsetree.PStr (copy_structure x0) - | From.Parsetree.PSig x0 -> - To.Parsetree.PSig (copy_signature x0) - | From.Parsetree.PTyp x0 -> - To.Parsetree.PTyp (copy_core_type x0) - | From.Parsetree.PPat (x0,x1) -> - To.Parsetree.PPat - ((copy_pattern x0), - (copy_option copy_expression x1)) - -and copy_structure : - From.Parsetree.structure -> To.Parsetree.structure = - fun x -> List.map copy_structure_item x - -and copy_structure_item : - From.Parsetree.structure_item -> To.Parsetree.structure_item = - fun - { From.Parsetree.pstr_desc = pstr_desc; - From.Parsetree.pstr_loc = pstr_loc } - -> - { - To.Parsetree.pstr_desc = - (copy_structure_item_desc pstr_desc); - To.Parsetree.pstr_loc = (copy_location pstr_loc) - } - -and copy_structure_item_desc : - From.Parsetree.structure_item_desc -> - To.Parsetree.structure_item_desc - = - function - | From.Parsetree.Pstr_eval (x0,x1) -> - To.Parsetree.Pstr_eval - ((copy_expression x0), - (copy_attributes x1)) - | From.Parsetree.Pstr_value (x0,x1) -> - To.Parsetree.Pstr_value - ((copy_rec_flag x0), - (List.map copy_value_binding x1)) - | From.Parsetree.Pstr_primitive x0 -> - To.Parsetree.Pstr_primitive - (copy_value_description x0) - | From.Parsetree.Pstr_type (x0,x1) -> - To.Parsetree.Pstr_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Pstr_typext x0 -> - To.Parsetree.Pstr_typext - (copy_type_extension x0) - | From.Parsetree.Pstr_exception x0 -> - To.Parsetree.Pstr_exception - (copy_extension_constructor x0) - | From.Parsetree.Pstr_module x0 -> - To.Parsetree.Pstr_module - (copy_module_binding x0) - | From.Parsetree.Pstr_recmodule x0 -> - To.Parsetree.Pstr_recmodule - (List.map copy_module_binding x0) - | From.Parsetree.Pstr_modtype x0 -> - To.Parsetree.Pstr_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Pstr_open x0 -> - To.Parsetree.Pstr_open - (copy_open_description x0) - | From.Parsetree.Pstr_class x0 -> - To.Parsetree.Pstr_class - (List.map copy_class_declaration x0) - | From.Parsetree.Pstr_class_type x0 -> - To.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Pstr_include x0 -> - To.Parsetree.Pstr_include - (copy_include_declaration x0) - | From.Parsetree.Pstr_attribute x0 -> - To.Parsetree.Pstr_attribute (copy_attribute x0) - | From.Parsetree.Pstr_extension (x0,x1) -> - To.Parsetree.Pstr_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_include_declaration : - From.Parsetree.include_declaration -> - To.Parsetree.include_declaration - = - fun x -> - copy_include_infos copy_module_expr x - -and copy_class_declaration : - From.Parsetree.class_declaration -> To.Parsetree.class_declaration +let rec copy_out_type_extension : + Ast_406.Outcometree.out_type_extension -> + Ast_407.Outcometree.out_type_extension = - fun x -> - copy_class_infos copy_class_expr x - -and copy_class_expr : - From.Parsetree.class_expr -> To.Parsetree.class_expr = fun - { From.Parsetree.pcl_desc = pcl_desc; - From.Parsetree.pcl_loc = pcl_loc; - From.Parsetree.pcl_attributes = pcl_attributes } - -> + { Ast_406.Outcometree.otyext_name = otyext_name; + Ast_406.Outcometree.otyext_params = otyext_params; + Ast_406.Outcometree.otyext_constructors = otyext_constructors; + Ast_406.Outcometree.otyext_private = otyext_private } + -> { - To.Parsetree.pcl_desc = - (copy_class_expr_desc pcl_desc); - To.Parsetree.pcl_loc = (copy_location pcl_loc); - To.Parsetree.pcl_attributes = - (copy_attributes pcl_attributes) - } - -and copy_class_expr_desc : - From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = - function - | From.Parsetree.Pcl_constr (x0,x1) -> - To.Parsetree.Pcl_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcl_structure x0 -> - To.Parsetree.Pcl_structure - (copy_class_structure x0) - | From.Parsetree.Pcl_fun (x0,x1,x2,x3) -> - To.Parsetree.Pcl_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_class_expr x3)) - | From.Parsetree.Pcl_apply (x0,x1) -> - To.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pcl_let (x0,x1,x2) -> - To.Parsetree.Pcl_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_class_expr x2)) - | From.Parsetree.Pcl_constraint (x0,x1) -> - To.Parsetree.Pcl_constraint - ((copy_class_expr x0), - (copy_class_type x1)) - | From.Parsetree.Pcl_extension x0 -> - To.Parsetree.Pcl_extension (copy_extension x0) - | From.Parsetree.Pcl_open (ovf, loc, ce) -> - To.Parsetree.Pcl_open (copy_override_flag ovf, - copy_loc copy_longident loc, - copy_class_expr ce) - -and copy_class_structure : - From.Parsetree.class_structure -> To.Parsetree.class_structure = - fun - { From.Parsetree.pcstr_self = pcstr_self; - From.Parsetree.pcstr_fields = pcstr_fields } - -> - { - To.Parsetree.pcstr_self = - (copy_pattern pcstr_self); - To.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } - -and copy_class_field : - From.Parsetree.class_field -> To.Parsetree.class_field = - fun - { From.Parsetree.pcf_desc = pcf_desc; - From.Parsetree.pcf_loc = pcf_loc; - From.Parsetree.pcf_attributes = pcf_attributes } - -> - { - To.Parsetree.pcf_desc = - (copy_class_field_desc pcf_desc); - To.Parsetree.pcf_loc = (copy_location pcf_loc); - To.Parsetree.pcf_attributes = - (copy_attributes pcf_attributes) - } - -and copy_class_field_desc : - From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = - function - | From.Parsetree.Pcf_inherit (x0,x1,x2) -> - To.Parsetree.Pcf_inherit - ((copy_override_flag x0), - (copy_class_expr x1), - (copy_option (copy_loc (fun x -> x)) x2)) - | From.Parsetree.Pcf_val x0 -> - To.Parsetree.Pcf_val - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_method x0 -> - To.Parsetree.Pcf_method - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_private_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_constraint x0 -> - To.Parsetree.Pcf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pcf_initializer x0 -> - To.Parsetree.Pcf_initializer - (copy_expression x0) - | From.Parsetree.Pcf_attribute x0 -> - To.Parsetree.Pcf_attribute (copy_attribute x0) - | From.Parsetree.Pcf_extension x0 -> - To.Parsetree.Pcf_extension (copy_extension x0) - -and copy_class_field_kind : - From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = - function - | From.Parsetree.Cfk_virtual x0 -> - To.Parsetree.Cfk_virtual (copy_core_type x0) - | From.Parsetree.Cfk_concrete (x0,x1) -> - To.Parsetree.Cfk_concrete - ((copy_override_flag x0), - (copy_expression x1)) - -and copy_module_binding : - From.Parsetree.module_binding -> To.Parsetree.module_binding = - fun - { From.Parsetree.pmb_name = pmb_name; - From.Parsetree.pmb_expr = pmb_expr; - From.Parsetree.pmb_attributes = pmb_attributes; - From.Parsetree.pmb_loc = pmb_loc } - -> - { - To.Parsetree.pmb_name = - (copy_loc (fun x -> x) pmb_name); - To.Parsetree.pmb_expr = - (copy_module_expr pmb_expr); - To.Parsetree.pmb_attributes = - (copy_attributes pmb_attributes); - To.Parsetree.pmb_loc = (copy_location pmb_loc) - } - -and copy_module_expr : - From.Parsetree.module_expr -> To.Parsetree.module_expr = - fun - { From.Parsetree.pmod_desc = pmod_desc; - From.Parsetree.pmod_loc = pmod_loc; - From.Parsetree.pmod_attributes = pmod_attributes } - -> - { - To.Parsetree.pmod_desc = - (copy_module_expr_desc pmod_desc); - To.Parsetree.pmod_loc = (copy_location pmod_loc); - To.Parsetree.pmod_attributes = - (copy_attributes pmod_attributes) - } - -and copy_module_expr_desc : - From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = - function - | From.Parsetree.Pmod_ident x0 -> - To.Parsetree.Pmod_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmod_structure x0 -> - To.Parsetree.Pmod_structure (copy_structure x0) - | From.Parsetree.Pmod_functor (x0,x1,x2) -> - To.Parsetree.Pmod_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_expr x2)) - | From.Parsetree.Pmod_apply (x0,x1) -> - To.Parsetree.Pmod_apply - ((copy_module_expr x0), - (copy_module_expr x1)) - | From.Parsetree.Pmod_constraint (x0,x1) -> - To.Parsetree.Pmod_constraint - ((copy_module_expr x0), - (copy_module_type x1)) - | From.Parsetree.Pmod_unpack x0 -> - To.Parsetree.Pmod_unpack (copy_expression x0) - | From.Parsetree.Pmod_extension x0 -> - To.Parsetree.Pmod_extension (copy_extension x0) - -and copy_module_type : - From.Parsetree.module_type -> To.Parsetree.module_type = - fun - { From.Parsetree.pmty_desc = pmty_desc; - From.Parsetree.pmty_loc = pmty_loc; - From.Parsetree.pmty_attributes = pmty_attributes } - -> - { - To.Parsetree.pmty_desc = - (copy_module_type_desc pmty_desc); - To.Parsetree.pmty_loc = (copy_location pmty_loc); - To.Parsetree.pmty_attributes = - (copy_attributes pmty_attributes) - } - -and copy_module_type_desc : - From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = - function - | From.Parsetree.Pmty_ident x0 -> - To.Parsetree.Pmty_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmty_signature x0 -> - To.Parsetree.Pmty_signature (copy_signature x0) - | From.Parsetree.Pmty_functor (x0,x1,x2) -> - To.Parsetree.Pmty_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_type x2)) - | From.Parsetree.Pmty_with (x0,x1) -> - To.Parsetree.Pmty_with - ((copy_module_type x0), - (List.map copy_with_constraint x1)) - | From.Parsetree.Pmty_typeof x0 -> - To.Parsetree.Pmty_typeof (copy_module_expr x0) - | From.Parsetree.Pmty_extension x0 -> - To.Parsetree.Pmty_extension (copy_extension x0) - | From.Parsetree.Pmty_alias x0 -> - To.Parsetree.Pmty_alias - (copy_loc copy_longident x0) - -and copy_with_constraint : - From.Parsetree.with_constraint -> To.Parsetree.with_constraint = - function - | From.Parsetree.Pwith_type (x0,x1) -> - To.Parsetree.Pwith_type - ((copy_loc copy_longident x0), - (copy_type_declaration x1)) - | From.Parsetree.Pwith_module (x0,x1) -> - To.Parsetree.Pwith_module - ((copy_loc copy_longident x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pwith_typesubst (x0, x1) -> - To.Parsetree.Pwith_typesubst - (copy_loc copy_longident x0, copy_type_declaration x1) - | From.Parsetree.Pwith_modsubst (x0,x1) -> - To.Parsetree.Pwith_modsubst - (copy_loc copy_longident x0, copy_loc copy_longident x1) - -and copy_signature : - From.Parsetree.signature -> To.Parsetree.signature = - fun x -> List.map copy_signature_item x - -and copy_signature_item : - From.Parsetree.signature_item -> To.Parsetree.signature_item = - fun - { From.Parsetree.psig_desc = psig_desc; - From.Parsetree.psig_loc = psig_loc } - -> - { - To.Parsetree.psig_desc = - (copy_signature_item_desc psig_desc); - To.Parsetree.psig_loc = (copy_location psig_loc) - } - -and copy_signature_item_desc : - From.Parsetree.signature_item_desc -> - To.Parsetree.signature_item_desc - = - function - | From.Parsetree.Psig_value x0 -> - To.Parsetree.Psig_value - (copy_value_description x0) - | From.Parsetree.Psig_type (x0,x1) -> - To.Parsetree.Psig_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Psig_typext x0 -> - To.Parsetree.Psig_typext - (copy_type_extension x0) - | From.Parsetree.Psig_exception x0 -> - To.Parsetree.Psig_exception - (copy_extension_constructor x0) - | From.Parsetree.Psig_module x0 -> - To.Parsetree.Psig_module - (copy_module_declaration x0) - | From.Parsetree.Psig_recmodule x0 -> - To.Parsetree.Psig_recmodule - (List.map copy_module_declaration x0) - | From.Parsetree.Psig_modtype x0 -> - To.Parsetree.Psig_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Psig_open x0 -> - To.Parsetree.Psig_open - (copy_open_description x0) - | From.Parsetree.Psig_include x0 -> - To.Parsetree.Psig_include - (copy_include_description x0) - | From.Parsetree.Psig_class x0 -> - To.Parsetree.Psig_class - (List.map copy_class_description x0) - | From.Parsetree.Psig_class_type x0 -> - To.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Psig_attribute x0 -> - To.Parsetree.Psig_attribute (copy_attribute x0) - | From.Parsetree.Psig_extension (x0,x1) -> - To.Parsetree.Psig_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_class_type_declaration : - From.Parsetree.class_type_declaration -> - To.Parsetree.class_type_declaration - = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_description : - From.Parsetree.class_description -> To.Parsetree.class_description - = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_type : - From.Parsetree.class_type -> To.Parsetree.class_type = - fun - { From.Parsetree.pcty_desc = pcty_desc; - From.Parsetree.pcty_loc = pcty_loc; - From.Parsetree.pcty_attributes = pcty_attributes } - -> - { - To.Parsetree.pcty_desc = - (copy_class_type_desc pcty_desc); - To.Parsetree.pcty_loc = (copy_location pcty_loc); - To.Parsetree.pcty_attributes = - (copy_attributes pcty_attributes) - } - -and copy_class_type_desc : - From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = - function - | From.Parsetree.Pcty_constr (x0,x1) -> - To.Parsetree.Pcty_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcty_signature x0 -> - To.Parsetree.Pcty_signature - (copy_class_signature x0) - | From.Parsetree.Pcty_arrow (x0,x1,x2) -> - To.Parsetree.Pcty_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_class_type x2)) - | From.Parsetree.Pcty_extension x0 -> - To.Parsetree.Pcty_extension (copy_extension x0) - | From.Parsetree.Pcty_open (ovf, loc, cty) -> - To.Parsetree.Pcty_open (copy_override_flag ovf, - copy_loc copy_longident loc, - copy_class_type cty) - -and copy_class_signature : - From.Parsetree.class_signature -> To.Parsetree.class_signature = - fun - { From.Parsetree.pcsig_self = pcsig_self; - From.Parsetree.pcsig_fields = pcsig_fields } - -> - { - To.Parsetree.pcsig_self = - (copy_core_type pcsig_self); - To.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } - -and copy_class_type_field : - From.Parsetree.class_type_field -> To.Parsetree.class_type_field = - fun - { From.Parsetree.pctf_desc = pctf_desc; - From.Parsetree.pctf_loc = pctf_loc; - From.Parsetree.pctf_attributes = pctf_attributes } - -> - { - To.Parsetree.pctf_desc = - (copy_class_type_field_desc pctf_desc); - To.Parsetree.pctf_loc = (copy_location pctf_loc); - To.Parsetree.pctf_attributes = - (copy_attributes pctf_attributes) - } - -and copy_class_type_field_desc : - From.Parsetree.class_type_field_desc -> - To.Parsetree.class_type_field_desc - = - function - | From.Parsetree.Pctf_inherit x0 -> - To.Parsetree.Pctf_inherit (copy_class_type x0) - | From.Parsetree.Pctf_val x0 -> - To.Parsetree.Pctf_val - (let (x0,x1,x2,x3) = x0 in - (copy_loc (fun x -> x) x0, (copy_mutable_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_method x0 -> - To.Parsetree.Pctf_method - (let (x0,x1,x2,x3) = x0 in - (copy_loc (fun x -> x) x0, (copy_private_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_constraint x0 -> - To.Parsetree.Pctf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pctf_attribute x0 -> - To.Parsetree.Pctf_attribute (copy_attribute x0) - | From.Parsetree.Pctf_extension x0 -> - To.Parsetree.Pctf_extension (copy_extension x0) - -and copy_extension : - From.Parsetree.extension -> To.Parsetree.extension = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.class_infos -> 'g0 To.Parsetree.class_infos - = - fun f0 -> - fun - { From.Parsetree.pci_virt = pci_virt; - From.Parsetree.pci_params = pci_params; - From.Parsetree.pci_name = pci_name; - From.Parsetree.pci_expr = pci_expr; - From.Parsetree.pci_loc = pci_loc; - From.Parsetree.pci_attributes = pci_attributes } - -> - { - To.Parsetree.pci_virt = - (copy_virtual_flag pci_virt); - To.Parsetree.pci_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) pci_params); - To.Parsetree.pci_name = - (copy_loc (fun x -> x) pci_name); - To.Parsetree.pci_expr = (f0 pci_expr); - To.Parsetree.pci_loc = (copy_location pci_loc); - To.Parsetree.pci_attributes = - (copy_attributes pci_attributes) - } - -and copy_virtual_flag : - From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = - function - | From.Asttypes.Virtual -> To.Asttypes.Virtual - | From.Asttypes.Concrete -> To.Asttypes.Concrete - -and copy_include_description : - From.Parsetree.include_description -> - To.Parsetree.include_description - = - fun x -> - copy_include_infos copy_module_type x - -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.include_infos -> - 'g0 To.Parsetree.include_infos - = - fun f0 -> - fun - { From.Parsetree.pincl_mod = pincl_mod; - From.Parsetree.pincl_loc = pincl_loc; - From.Parsetree.pincl_attributes = pincl_attributes } - -> - { - To.Parsetree.pincl_mod = (f0 pincl_mod); - To.Parsetree.pincl_loc = (copy_location pincl_loc); - To.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } - -and copy_open_description : - From.Parsetree.open_description -> To.Parsetree.open_description = - fun - { From.Parsetree.popen_lid = popen_lid; - From.Parsetree.popen_override = popen_override; - From.Parsetree.popen_loc = popen_loc; - From.Parsetree.popen_attributes = popen_attributes } - -> - { - To.Parsetree.popen_lid = - (copy_loc copy_longident popen_lid); - To.Parsetree.popen_override = - (copy_override_flag popen_override); - To.Parsetree.popen_loc = (copy_location popen_loc); - To.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } - -and copy_override_flag : - From.Asttypes.override_flag -> To.Asttypes.override_flag = - function - | From.Asttypes.Override -> To.Asttypes.Override - | From.Asttypes.Fresh -> To.Asttypes.Fresh - -and copy_module_type_declaration : - From.Parsetree.module_type_declaration -> - To.Parsetree.module_type_declaration - = - fun - { From.Parsetree.pmtd_name = pmtd_name; - From.Parsetree.pmtd_type = pmtd_type; - From.Parsetree.pmtd_attributes = pmtd_attributes; - From.Parsetree.pmtd_loc = pmtd_loc } - -> - { - To.Parsetree.pmtd_name = - (copy_loc (fun x -> x) pmtd_name); - To.Parsetree.pmtd_type = - (copy_option copy_module_type pmtd_type); - To.Parsetree.pmtd_attributes = - (copy_attributes pmtd_attributes); - To.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } - -and copy_module_declaration : - From.Parsetree.module_declaration -> - To.Parsetree.module_declaration - = - fun - { From.Parsetree.pmd_name = pmd_name; - From.Parsetree.pmd_type = pmd_type; - From.Parsetree.pmd_attributes = pmd_attributes; - From.Parsetree.pmd_loc = pmd_loc } - -> - { - To.Parsetree.pmd_name = - (copy_loc (fun x -> x) pmd_name); - To.Parsetree.pmd_type = - (copy_module_type pmd_type); - To.Parsetree.pmd_attributes = - (copy_attributes pmd_attributes); - To.Parsetree.pmd_loc = (copy_location pmd_loc) - } - -and copy_type_extension : - From.Parsetree.type_extension -> To.Parsetree.type_extension = - fun - { From.Parsetree.ptyext_path = ptyext_path; - From.Parsetree.ptyext_params = ptyext_params; - From.Parsetree.ptyext_constructors = ptyext_constructors; - From.Parsetree.ptyext_private = ptyext_private; - From.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - To.Parsetree.ptyext_path = - (copy_loc copy_longident ptyext_path); - To.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptyext_params); - To.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor - ptyext_constructors); - To.Parsetree.ptyext_private = - (copy_private_flag ptyext_private); - To.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } - -and copy_extension_constructor : - From.Parsetree.extension_constructor -> - To.Parsetree.extension_constructor - = - fun - { From.Parsetree.pext_name = pext_name; - From.Parsetree.pext_kind = pext_kind; - From.Parsetree.pext_loc = pext_loc; - From.Parsetree.pext_attributes = pext_attributes } - -> - { - To.Parsetree.pext_name = - (copy_loc (fun x -> x) pext_name); - To.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - To.Parsetree.pext_loc = (copy_location pext_loc); - To.Parsetree.pext_attributes = - (copy_attributes pext_attributes) - } - -and copy_extension_constructor_kind : - From.Parsetree.extension_constructor_kind -> - To.Parsetree.extension_constructor_kind - = - function - | From.Parsetree.Pext_decl (x0,x1) -> - To.Parsetree.Pext_decl - ((copy_constructor_arguments x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pext_rebind x0 -> - To.Parsetree.Pext_rebind - (copy_loc copy_longident x0) - -and copy_type_declaration : - From.Parsetree.type_declaration -> To.Parsetree.type_declaration = - fun - { From.Parsetree.ptype_name = ptype_name; - From.Parsetree.ptype_params = ptype_params; - From.Parsetree.ptype_cstrs = ptype_cstrs; - From.Parsetree.ptype_kind = ptype_kind; - From.Parsetree.ptype_private = ptype_private; - From.Parsetree.ptype_manifest = ptype_manifest; - From.Parsetree.ptype_attributes = ptype_attributes; - From.Parsetree.ptype_loc = ptype_loc } - -> - { - To.Parsetree.ptype_name = - (copy_loc (fun x -> x) ptype_name); - To.Parsetree.ptype_params = + Ast_407.Outcometree.otyext_name = otyext_name; + Ast_407.Outcometree.otyext_params = + (List.map (fun x -> x) otyext_params); + Ast_407.Outcometree.otyext_constructors = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptype_params); - To.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0,x1,x2) = x in - ((copy_core_type x0), - (copy_core_type x1), - (copy_location x2))) ptype_cstrs); - To.Parsetree.ptype_kind = - (copy_type_kind ptype_kind); - To.Parsetree.ptype_private = - (copy_private_flag ptype_private); - To.Parsetree.ptype_manifest = - (copy_option copy_core_type ptype_manifest); - To.Parsetree.ptype_attributes = - (copy_attributes ptype_attributes); - To.Parsetree.ptype_loc = (copy_location ptype_loc) - } - -and copy_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = - function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - -and copy_type_kind : - From.Parsetree.type_kind -> To.Parsetree.type_kind = - function - | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract - | From.Parsetree.Ptype_variant x0 -> - To.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | From.Parsetree.Ptype_record x0 -> - To.Parsetree.Ptype_record - (List.map copy_label_declaration x0) - | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open - -and copy_constructor_declaration : - From.Parsetree.constructor_declaration -> - To.Parsetree.constructor_declaration - = - fun - { From.Parsetree.pcd_name = pcd_name; - From.Parsetree.pcd_args = pcd_args; - From.Parsetree.pcd_res = pcd_res; - From.Parsetree.pcd_loc = pcd_loc; - From.Parsetree.pcd_attributes = pcd_attributes } - -> - { - To.Parsetree.pcd_name = - (copy_loc (fun x -> x) pcd_name); - To.Parsetree.pcd_args = - (copy_constructor_arguments pcd_args); - To.Parsetree.pcd_res = - (copy_option copy_core_type pcd_res); - To.Parsetree.pcd_loc = (copy_location pcd_loc); - To.Parsetree.pcd_attributes = - (copy_attributes pcd_attributes) - } - -and copy_constructor_arguments : - From.Parsetree.constructor_arguments -> - To.Parsetree.constructor_arguments - = - function - | From.Parsetree.Pcstr_tuple x0 -> - To.Parsetree.Pcstr_tuple - (List.map copy_core_type x0) - | From.Parsetree.Pcstr_record x0 -> - To.Parsetree.Pcstr_record - (List.map copy_label_declaration x0) - -and copy_label_declaration : - From.Parsetree.label_declaration -> To.Parsetree.label_declaration - = - fun - { From.Parsetree.pld_name = pld_name; - From.Parsetree.pld_mutable = pld_mutable; - From.Parsetree.pld_type = pld_type; - From.Parsetree.pld_loc = pld_loc; - From.Parsetree.pld_attributes = pld_attributes } - -> - { - To.Parsetree.pld_name = - (copy_loc (fun x -> x) pld_name); - To.Parsetree.pld_mutable = - (copy_mutable_flag pld_mutable); - To.Parsetree.pld_type = - (copy_core_type pld_type); - To.Parsetree.pld_loc = (copy_location pld_loc); - To.Parsetree.pld_attributes = - (copy_attributes pld_attributes) - } - -and copy_mutable_flag : - From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = - function - | From.Asttypes.Immutable -> To.Asttypes.Immutable - | From.Asttypes.Mutable -> To.Asttypes.Mutable - -and copy_variance : - From.Asttypes.variance -> To.Asttypes.variance = - function - | From.Asttypes.Covariant -> To.Asttypes.Covariant - | From.Asttypes.Contravariant -> To.Asttypes.Contravariant - | From.Asttypes.Invariant -> To.Asttypes.Invariant - -and copy_value_description : - From.Parsetree.value_description -> To.Parsetree.value_description - = - fun - { From.Parsetree.pval_name = pval_name; - From.Parsetree.pval_type = pval_type; - From.Parsetree.pval_prim = pval_prim; - From.Parsetree.pval_attributes = pval_attributes; - From.Parsetree.pval_loc = pval_loc } - -> - { - To.Parsetree.pval_name = - (copy_loc (fun x -> x) pval_name); - To.Parsetree.pval_type = - (copy_core_type pval_type); - To.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - To.Parsetree.pval_attributes = - (copy_attributes pval_attributes); - To.Parsetree.pval_loc = (copy_location pval_loc) - } - -and copy_arg_label : - From.Asttypes.arg_label -> To.Asttypes.arg_label = - function - | From.Asttypes.Nolabel -> To.Asttypes.Nolabel - | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 - | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 - -and copy_closed_flag : - From.Asttypes.closed_flag -> To.Asttypes.closed_flag = - function - | From.Asttypes.Closed -> To.Asttypes.Closed - | From.Asttypes.Open -> To.Asttypes.Open - -and copy_label : - From.Asttypes.label -> To.Asttypes.label = fun x -> x - -and copy_rec_flag : - From.Asttypes.rec_flag -> To.Asttypes.rec_flag = - function - | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive - | From.Asttypes.Recursive -> To.Asttypes.Recursive - -and copy_constant : - From.Parsetree.constant -> To.Parsetree.constant = - function - | From.Parsetree.Pconst_integer (x0,x1) -> - To.Parsetree.Pconst_integer (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 - | From.Parsetree.Pconst_string (x0,x1) -> - To.Parsetree.Pconst_string (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_float (x0,x1) -> - To.Parsetree.Pconst_float (x0, (copy_option (fun x -> x) x1)) - -and copy_option : 'f0 'g0 . ('f0 -> 'g0) -> 'f0 option -> 'g0 option = - fun f0 -> function | None -> None | Some x0 -> Some (f0 x0) - -and copy_longident : From.Longident.t -> To.Longident.t = - function - | From.Longident.Lident x0 -> To.Longident.Lident x0 - | From.Longident.Ldot (x0,x1) -> - To.Longident.Ldot ((copy_longident x0), x1) - | From.Longident.Lapply (x0,x1) -> - To.Longident.Lapply - ((copy_longident x0), (copy_longident x1)) - -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc - = - fun f0 -> - fun { From.Asttypes.txt = txt; From.Asttypes.loc = loc } -> - { - To.Asttypes.txt = (f0 txt); - To.Asttypes.loc = (copy_location loc) - } - -and copy_location : From.Location.t -> To.Location.t = - fun - { From.Location.loc_start = loc_start; - From.Location.loc_end = loc_end; - From.Location.loc_ghost = loc_ghost } - -> - { - To.Location.loc_start = (copy_Lexing_position loc_start); - To.Location.loc_end = (copy_Lexing_position loc_end); - To.Location.loc_ghost = (copy_bool loc_ghost) - } - -and copy_bool : bool -> bool = function | false -> false | true -> true - -and copy_Lexing_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum + (fun x -> + let (x0, x1, x2) = x in + (x0, (List.map copy_out_type x1), + (Option.map copy_out_type x2))) otyext_constructors); + Ast_407.Outcometree.otyext_private = (copy_private_flag otyext_private) } - -let rec copy_out_phrase : - From.Outcometree.out_phrase -> To.Outcometree.out_phrase = +and copy_out_phrase : + Ast_406.Outcometree.out_phrase -> Ast_407.Outcometree.out_phrase = function - | From.Outcometree.Ophr_eval (x0,x1) -> - To.Outcometree.Ophr_eval - ((copy_out_value x0), - (copy_out_type x1)) - | From.Outcometree.Ophr_signature x0 -> - To.Outcometree.Ophr_signature + | Ast_406.Outcometree.Ophr_eval (x0, x1) -> + Ast_407.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1)) + | Ast_406.Outcometree.Ophr_signature x0 -> + Ast_407.Outcometree.Ophr_signature (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_sig_item x0), - (copy_option copy_out_value x1))) x0) - | From.Outcometree.Ophr_exception x0 -> - To.Outcometree.Ophr_exception - (let (x0,x1) = x0 in - ((copy_exn x0), (copy_out_value x1))) - -and copy_exn : exn -> exn = fun x -> x - + (fun x -> + let (x0, x1) = x in + ((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0) + | Ast_406.Outcometree.Ophr_exception x0 -> + Ast_407.Outcometree.Ophr_exception + (let (x0, x1) = x0 in (x0, (copy_out_value x1))) and copy_out_sig_item : - From.Outcometree.out_sig_item -> To.Outcometree.out_sig_item = + Ast_406.Outcometree.out_sig_item -> Ast_407.Outcometree.out_sig_item = function - | From.Outcometree.Osig_class (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class - ((copy_bool x0), x1, + | Ast_406.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> + Ast_407.Outcometree.Osig_class + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_class_type (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class_type - ((copy_bool x0), x1, + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_406.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> + Ast_407.Outcometree.Osig_class_type + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_typext (x0,x1) -> - To.Outcometree.Osig_typext - ((copy_out_extension_constructor x0), - (copy_out_ext_status x1)) - | From.Outcometree.Osig_modtype (x0,x1) -> - To.Outcometree.Osig_modtype - (x0, (copy_out_module_type x1)) - | From.Outcometree.Osig_module (x0,x1,x2) -> - To.Outcometree.Osig_module - (x0, (copy_out_module_type x1), - (copy_out_rec_status x2)) - | From.Outcometree.Osig_type (x0,x1) -> - To.Outcometree.Osig_type - ((copy_out_type_decl x0), - (copy_out_rec_status x1)) - | From.Outcometree.Osig_value x0 -> - To.Outcometree.Osig_value - (copy_out_val_decl x0) - | From.Outcometree.Osig_ellipsis -> To.Outcometree.Osig_ellipsis - + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_406.Outcometree.Osig_typext (x0, x1) -> + Ast_407.Outcometree.Osig_typext + ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) + | Ast_406.Outcometree.Osig_modtype (x0, x1) -> + Ast_407.Outcometree.Osig_modtype (x0, (copy_out_module_type x1)) + | Ast_406.Outcometree.Osig_module (x0, x1, x2) -> + Ast_407.Outcometree.Osig_module + (x0, (copy_out_module_type x1), (copy_out_rec_status x2)) + | Ast_406.Outcometree.Osig_type (x0, x1) -> + Ast_407.Outcometree.Osig_type + ((copy_out_type_decl x0), (copy_out_rec_status x1)) + | Ast_406.Outcometree.Osig_value x0 -> + Ast_407.Outcometree.Osig_value (copy_out_val_decl x0) + | Ast_406.Outcometree.Osig_ellipsis -> Ast_407.Outcometree.Osig_ellipsis and copy_out_val_decl : - From.Outcometree.out_val_decl -> To.Outcometree.out_val_decl = + Ast_406.Outcometree.out_val_decl -> Ast_407.Outcometree.out_val_decl = fun - { From.Outcometree.oval_name = oval_name; - From.Outcometree.oval_type = oval_type; - From.Outcometree.oval_prims = oval_prims; - From.Outcometree.oval_attributes = oval_attributes } - -> + { Ast_406.Outcometree.oval_name = oval_name; + Ast_406.Outcometree.oval_type = oval_type; + Ast_406.Outcometree.oval_prims = oval_prims; + Ast_406.Outcometree.oval_attributes = oval_attributes } + -> { - To.Outcometree.oval_name = oval_name; - To.Outcometree.oval_type = - (copy_out_type oval_type); - To.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); - To.Outcometree.oval_attributes = + Ast_407.Outcometree.oval_name = oval_name; + Ast_407.Outcometree.oval_type = (copy_out_type oval_type); + Ast_407.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); + Ast_407.Outcometree.oval_attributes = (List.map copy_out_attribute oval_attributes) } - and copy_out_type_decl : - From.Outcometree.out_type_decl -> To.Outcometree.out_type_decl = + Ast_406.Outcometree.out_type_decl -> Ast_407.Outcometree.out_type_decl = fun - { From.Outcometree.otype_name = otype_name; - From.Outcometree.otype_params = otype_params; - From.Outcometree.otype_type = otype_type; - From.Outcometree.otype_private = otype_private; - From.Outcometree.otype_immediate = otype_immediate; - From.Outcometree.otype_unboxed = otype_unboxed; - From.Outcometree.otype_cstrs = otype_cstrs } - -> + { Ast_406.Outcometree.otype_name = otype_name; + Ast_406.Outcometree.otype_params = otype_params; + Ast_406.Outcometree.otype_type = otype_type; + Ast_406.Outcometree.otype_private = otype_private; + Ast_406.Outcometree.otype_immediate = otype_immediate; + Ast_406.Outcometree.otype_unboxed = otype_unboxed; + Ast_406.Outcometree.otype_cstrs = otype_cstrs } + -> { - To.Outcometree.otype_name = otype_name; - To.Outcometree.otype_params = + Ast_407.Outcometree.otype_name = otype_name; + Ast_407.Outcometree.otype_params = (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) otype_params); - To.Outcometree.otype_type = - (copy_out_type otype_type); - To.Outcometree.otype_private = - (copy_From_Asttypes_private_flag otype_private); - To.Outcometree.otype_immediate = (copy_bool otype_immediate); - To.Outcometree.otype_unboxed = (copy_bool otype_unboxed); - To.Outcometree.otype_cstrs = + Ast_407.Outcometree.otype_type = (copy_out_type otype_type); + Ast_407.Outcometree.otype_private = (copy_private_flag otype_private); + Ast_407.Outcometree.otype_immediate = otype_immediate; + Ast_407.Outcometree.otype_unboxed = otype_unboxed; + Ast_407.Outcometree.otype_cstrs = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_type x0), - (copy_out_type x1))) otype_cstrs) + (fun x -> + let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1))) + otype_cstrs) } - and copy_out_module_type : - From.Outcometree.out_module_type -> To.Outcometree.out_module_type + Ast_406.Outcometree.out_module_type -> Ast_407.Outcometree.out_module_type = function - | From.Outcometree.Omty_abstract -> To.Outcometree.Omty_abstract - | From.Outcometree.Omty_functor (x0,x1,x2) -> - To.Outcometree.Omty_functor - (x0, (copy_option copy_out_module_type x1), - (copy_out_module_type x2)) - | From.Outcometree.Omty_ident x0 -> - To.Outcometree.Omty_ident (copy_out_ident x0) - | From.Outcometree.Omty_signature x0 -> - To.Outcometree.Omty_signature - (List.map copy_out_sig_item x0) - | From.Outcometree.Omty_alias x0 -> - To.Outcometree.Omty_alias (copy_out_ident x0) - + | Ast_406.Outcometree.Omty_abstract -> Ast_407.Outcometree.Omty_abstract + | Ast_406.Outcometree.Omty_functor (x0, x1, x2) -> + Ast_407.Outcometree.Omty_functor + (x0, (Option.map copy_out_module_type x1), (copy_out_module_type x2)) + | Ast_406.Outcometree.Omty_ident x0 -> + Ast_407.Outcometree.Omty_ident (copy_out_ident x0) + | Ast_406.Outcometree.Omty_signature x0 -> + Ast_407.Outcometree.Omty_signature (List.map copy_out_sig_item x0) + | Ast_406.Outcometree.Omty_alias x0 -> + Ast_407.Outcometree.Omty_alias (copy_out_ident x0) and copy_out_ext_status : - From.Outcometree.out_ext_status -> To.Outcometree.out_ext_status = + Ast_406.Outcometree.out_ext_status -> Ast_407.Outcometree.out_ext_status = function - | From.Outcometree.Oext_first -> To.Outcometree.Oext_first - | From.Outcometree.Oext_next -> To.Outcometree.Oext_next - | From.Outcometree.Oext_exception -> To.Outcometree.Oext_exception - + | Ast_406.Outcometree.Oext_first -> Ast_407.Outcometree.Oext_first + | Ast_406.Outcometree.Oext_next -> Ast_407.Outcometree.Oext_next + | Ast_406.Outcometree.Oext_exception -> Ast_407.Outcometree.Oext_exception and copy_out_extension_constructor : - From.Outcometree.out_extension_constructor -> - To.Outcometree.out_extension_constructor + Ast_406.Outcometree.out_extension_constructor -> + Ast_407.Outcometree.out_extension_constructor = fun - { From.Outcometree.oext_name = oext_name; - From.Outcometree.oext_type_name = oext_type_name; - From.Outcometree.oext_type_params = oext_type_params; - From.Outcometree.oext_args = oext_args; - From.Outcometree.oext_ret_type = oext_ret_type; - From.Outcometree.oext_private = oext_private } - -> + { Ast_406.Outcometree.oext_name = oext_name; + Ast_406.Outcometree.oext_type_name = oext_type_name; + Ast_406.Outcometree.oext_type_params = oext_type_params; + Ast_406.Outcometree.oext_args = oext_args; + Ast_406.Outcometree.oext_ret_type = oext_ret_type; + Ast_406.Outcometree.oext_private = oext_private } + -> { - To.Outcometree.oext_name = oext_name; - To.Outcometree.oext_type_name = oext_type_name; - To.Outcometree.oext_type_params = - (List.map (fun x -> x) oext_type_params); - To.Outcometree.oext_args = - (List.map copy_out_type oext_args); - To.Outcometree.oext_ret_type = - (copy_option copy_out_type oext_ret_type); - To.Outcometree.oext_private = - (copy_From_Asttypes_private_flag oext_private) + Ast_407.Outcometree.oext_name = oext_name; + Ast_407.Outcometree.oext_type_name = oext_type_name; + Ast_407.Outcometree.oext_type_params = + (List.map (fun x -> x) oext_type_params); + Ast_407.Outcometree.oext_args = (List.map copy_out_type oext_args); + Ast_407.Outcometree.oext_ret_type = + (Option.map copy_out_type oext_ret_type); + Ast_407.Outcometree.oext_private = (copy_private_flag oext_private) } - -and copy_From_Asttypes_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = +and copy_private_flag : + Ast_406.Asttypes.private_flag -> Ast_407.Asttypes.private_flag = function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - + | Ast_406.Asttypes.Private -> Ast_407.Asttypes.Private + | Ast_406.Asttypes.Public -> Ast_407.Asttypes.Public and copy_out_rec_status : - From.Outcometree.out_rec_status -> To.Outcometree.out_rec_status = + Ast_406.Outcometree.out_rec_status -> Ast_407.Outcometree.out_rec_status = function - | From.Outcometree.Orec_not -> To.Outcometree.Orec_not - | From.Outcometree.Orec_first -> To.Outcometree.Orec_first - | From.Outcometree.Orec_next -> To.Outcometree.Orec_next - + | Ast_406.Outcometree.Orec_not -> Ast_407.Outcometree.Orec_not + | Ast_406.Outcometree.Orec_first -> Ast_407.Outcometree.Orec_first + | Ast_406.Outcometree.Orec_next -> Ast_407.Outcometree.Orec_next and copy_out_class_type : - From.Outcometree.out_class_type -> To.Outcometree.out_class_type = - function - | From.Outcometree.Octy_constr (x0,x1) -> - To.Outcometree.Octy_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Octy_arrow (x0,x1,x2) -> - To.Outcometree.Octy_arrow - (x0, (copy_out_type x1), - (copy_out_class_type x2)) - | From.Outcometree.Octy_signature (x0,x1) -> - To.Outcometree.Octy_signature - ((copy_option copy_out_type x0), + Ast_406.Outcometree.out_class_type -> Ast_407.Outcometree.out_class_type = + function + | Ast_406.Outcometree.Octy_constr (x0, x1) -> + Ast_407.Outcometree.Octy_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_406.Outcometree.Octy_arrow (x0, x1, x2) -> + Ast_407.Outcometree.Octy_arrow + (x0, (copy_out_type x1), (copy_out_class_type x2)) + | Ast_406.Outcometree.Octy_signature (x0, x1) -> + Ast_407.Outcometree.Octy_signature + ((Option.map copy_out_type x0), (List.map copy_out_class_sig_item x1)) - and copy_out_class_sig_item : - From.Outcometree.out_class_sig_item -> - To.Outcometree.out_class_sig_item + Ast_406.Outcometree.out_class_sig_item -> + Ast_407.Outcometree.out_class_sig_item = function - | From.Outcometree.Ocsg_constraint (x0,x1) -> - To.Outcometree.Ocsg_constraint - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Ocsg_method (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_method - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - | From.Outcometree.Ocsg_value (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_value - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - + | Ast_406.Outcometree.Ocsg_constraint (x0, x1) -> + Ast_407.Outcometree.Ocsg_constraint + ((copy_out_type x0), (copy_out_type x1)) + | Ast_406.Outcometree.Ocsg_method (x0, x1, x2, x3) -> + Ast_407.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3)) + | Ast_406.Outcometree.Ocsg_value (x0, x1, x2, x3) -> + Ast_407.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3)) and copy_out_type : - From.Outcometree.out_type -> To.Outcometree.out_type = - function - | From.Outcometree.Otyp_abstract -> To.Outcometree.Otyp_abstract - | From.Outcometree.Otyp_open -> To.Outcometree.Otyp_open - | From.Outcometree.Otyp_alias (x0,x1) -> - To.Outcometree.Otyp_alias - ((copy_out_type x0), x1) - | From.Outcometree.Otyp_arrow (x0,x1,x2) -> - To.Outcometree.Otyp_arrow - (x0, (copy_out_type x1), - (copy_out_type x2)) - | From.Outcometree.Otyp_class (x0,x1,x2) -> - To.Outcometree.Otyp_class - ((copy_bool x0), (copy_out_ident x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_constr (x0,x1) -> - To.Outcometree.Otyp_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Otyp_manifest (x0,x1) -> - To.Outcometree.Otyp_manifest - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Otyp_object (x0,x1) -> - To.Outcometree.Otyp_object - ((List.map - (fun x -> - let (x0,x1) = x in - (x0, (copy_out_type x1))) x0), - (copy_option copy_bool x1)) - | From.Outcometree.Otyp_record x0 -> - To.Outcometree.Otyp_record + Ast_406.Outcometree.out_type -> Ast_407.Outcometree.out_type = + function + | Ast_406.Outcometree.Otyp_abstract -> Ast_407.Outcometree.Otyp_abstract + | Ast_406.Outcometree.Otyp_open -> Ast_407.Outcometree.Otyp_open + | Ast_406.Outcometree.Otyp_alias (x0, x1) -> + Ast_407.Outcometree.Otyp_alias ((copy_out_type x0), x1) + | Ast_406.Outcometree.Otyp_arrow (x0, x1, x2) -> + Ast_407.Outcometree.Otyp_arrow + (x0, (copy_out_type x1), (copy_out_type x2)) + | Ast_406.Outcometree.Otyp_class (x0, x1, x2) -> + Ast_407.Outcometree.Otyp_class + (x0, (copy_out_ident x1), (List.map copy_out_type x2)) + | Ast_406.Outcometree.Otyp_constr (x0, x1) -> + Ast_407.Outcometree.Otyp_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_406.Outcometree.Otyp_manifest (x0, x1) -> + Ast_407.Outcometree.Otyp_manifest + ((copy_out_type x0), (copy_out_type x1)) + | Ast_406.Outcometree.Otyp_object (x0, x1) -> + Ast_407.Outcometree.Otyp_object + ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0), + (Option.map (fun x -> x) x1)) + | Ast_406.Outcometree.Otyp_record x0 -> + Ast_407.Outcometree.Otyp_record (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), (copy_out_type x2))) - x0) - | From.Outcometree.Otyp_stuff x0 -> To.Outcometree.Otyp_stuff x0 - | From.Outcometree.Otyp_sum x0 -> - To.Outcometree.Otyp_sum + (fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0) + | Ast_406.Outcometree.Otyp_stuff x0 -> Ast_407.Outcometree.Otyp_stuff x0 + | Ast_406.Outcometree.Otyp_sum x0 -> + Ast_407.Outcometree.Otyp_sum (List.map - (fun x -> - let (x0,x1,x2) = x in + (fun x -> + let (x0, x1, x2) = x in (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) x0) - | From.Outcometree.Otyp_tuple x0 -> - To.Outcometree.Otyp_tuple - (List.map copy_out_type x0) - | From.Outcometree.Otyp_var (x0,x1) -> - To.Outcometree.Otyp_var ((copy_bool x0), x1) - | From.Outcometree.Otyp_variant (x0,x1,x2,x3) -> - To.Outcometree.Otyp_variant - ((copy_bool x0), (copy_out_variant x1), - (copy_bool x2), - (copy_option (fun x -> List.map (fun x -> x) x) x3)) - | From.Outcometree.Otyp_poly (x0,x1) -> - To.Outcometree.Otyp_poly - ((List.map (fun x -> x) x0), (copy_out_type x1)) - | From.Outcometree.Otyp_module (x0,x1,x2) -> - To.Outcometree.Otyp_module - (x0, (List.map (fun x -> x) x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_attribute (x0,x1) -> - To.Outcometree.Otyp_attribute - ((copy_out_type x0), - (copy_out_attribute x1)) - -and copy_out_string : - From.Outcometree.out_string -> To.Outcometree.out_string = - function - | From.Outcometree.Ostr_string -> To.Outcometree.Ostr_string - | From.Outcometree.Ostr_bytes -> To.Outcometree.Ostr_bytes - + (Option.map copy_out_type x2))) x0) + | Ast_406.Outcometree.Otyp_tuple x0 -> + Ast_407.Outcometree.Otyp_tuple (List.map copy_out_type x0) + | Ast_406.Outcometree.Otyp_var (x0, x1) -> + Ast_407.Outcometree.Otyp_var (x0, x1) + | Ast_406.Outcometree.Otyp_variant (x0, x1, x2, x3) -> + Ast_407.Outcometree.Otyp_variant + (x0, (copy_out_variant x1), x2, + (Option.map (fun x -> List.map (fun x -> x) x) x3)) + | Ast_406.Outcometree.Otyp_poly (x0, x1) -> + Ast_407.Outcometree.Otyp_poly + ((List.map (fun x -> x) x0), (copy_out_type x1)) + | Ast_406.Outcometree.Otyp_module (x0, x1, x2) -> + Ast_407.Outcometree.Otyp_module + (x0, (List.map (fun x -> x) x1), (List.map copy_out_type x2)) + | Ast_406.Outcometree.Otyp_attribute (x0, x1) -> + Ast_407.Outcometree.Otyp_attribute + ((copy_out_type x0), (copy_out_attribute x1)) and copy_out_attribute : - From.Outcometree.out_attribute -> To.Outcometree.out_attribute = - fun { From.Outcometree.oattr_name = oattr_name } -> - { To.Outcometree.oattr_name = oattr_name } - + Ast_406.Outcometree.out_attribute -> Ast_407.Outcometree.out_attribute = + fun { Ast_406.Outcometree.oattr_name = oattr_name } -> + { Ast_407.Outcometree.oattr_name = oattr_name } and copy_out_variant : - From.Outcometree.out_variant -> To.Outcometree.out_variant = + Ast_406.Outcometree.out_variant -> Ast_407.Outcometree.out_variant = function - | From.Outcometree.Ovar_fields x0 -> - To.Outcometree.Ovar_fields + | Ast_406.Outcometree.Ovar_fields x0 -> + Ast_407.Outcometree.Ovar_fields (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), - (List.map copy_out_type x2))) x0) - | From.Outcometree.Ovar_typ x0 -> - To.Outcometree.Ovar_typ (copy_out_type x0) - + (fun x -> + let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2))) + x0) + | Ast_406.Outcometree.Ovar_typ x0 -> + Ast_407.Outcometree.Ovar_typ (copy_out_type x0) and copy_out_value : - From.Outcometree.out_value -> To.Outcometree.out_value = - function - | From.Outcometree.Oval_array x0 -> - To.Outcometree.Oval_array - (List.map copy_out_value x0) - | From.Outcometree.Oval_char x0 -> To.Outcometree.Oval_char x0 - | From.Outcometree.Oval_constr (x0,x1) -> - To.Outcometree.Oval_constr - ((copy_out_ident x0), - (List.map copy_out_value x1)) - | From.Outcometree.Oval_ellipsis -> To.Outcometree.Oval_ellipsis - | From.Outcometree.Oval_float x0 -> - To.Outcometree.Oval_float (copy_float x0) - | From.Outcometree.Oval_int x0 -> To.Outcometree.Oval_int x0 - | From.Outcometree.Oval_int32 x0 -> To.Outcometree.Oval_int32 x0 - | From.Outcometree.Oval_int64 x0 -> To.Outcometree.Oval_int64 x0 - | From.Outcometree.Oval_nativeint x0 -> - To.Outcometree.Oval_nativeint x0 - | From.Outcometree.Oval_list x0 -> - To.Outcometree.Oval_list - (List.map copy_out_value x0) - | From.Outcometree.Oval_printer x0 -> - To.Outcometree.Oval_printer x0 - | From.Outcometree.Oval_record x0 -> - To.Outcometree.Oval_record + Ast_406.Outcometree.out_value -> Ast_407.Outcometree.out_value = + function + | Ast_406.Outcometree.Oval_array x0 -> + Ast_407.Outcometree.Oval_array (List.map copy_out_value x0) + | Ast_406.Outcometree.Oval_char x0 -> Ast_407.Outcometree.Oval_char x0 + | Ast_406.Outcometree.Oval_constr (x0, x1) -> + Ast_407.Outcometree.Oval_constr + ((copy_out_ident x0), (List.map copy_out_value x1)) + | Ast_406.Outcometree.Oval_ellipsis -> Ast_407.Outcometree.Oval_ellipsis + | Ast_406.Outcometree.Oval_float x0 -> Ast_407.Outcometree.Oval_float x0 + | Ast_406.Outcometree.Oval_int x0 -> Ast_407.Outcometree.Oval_int x0 + | Ast_406.Outcometree.Oval_int32 x0 -> Ast_407.Outcometree.Oval_int32 x0 + | Ast_406.Outcometree.Oval_int64 x0 -> Ast_407.Outcometree.Oval_int64 x0 + | Ast_406.Outcometree.Oval_nativeint x0 -> + Ast_407.Outcometree.Oval_nativeint x0 + | Ast_406.Outcometree.Oval_list x0 -> + Ast_407.Outcometree.Oval_list (List.map copy_out_value x0) + | Ast_406.Outcometree.Oval_printer x0 -> + Ast_407.Outcometree.Oval_printer x0 + | Ast_406.Outcometree.Oval_record x0 -> + Ast_407.Outcometree.Oval_record (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_ident x0), - (copy_out_value x1))) x0) - | From.Outcometree.Oval_string (x0, x1, x2) -> - To.Outcometree.Oval_string (x0, x1, copy_out_string x2) - | From.Outcometree.Oval_stuff x0 -> To.Outcometree.Oval_stuff x0 - | From.Outcometree.Oval_tuple x0 -> - To.Outcometree.Oval_tuple - (List.map copy_out_value x0) - | From.Outcometree.Oval_variant (x0,x1) -> - To.Outcometree.Oval_variant - (x0, (copy_option copy_out_value x1)) - -and copy_float : float -> float = fun x -> x - -and copy_out_ident : - From.Outcometree.out_ident -> To.Outcometree.out_ident = - function - | From.Outcometree.Oide_apply (x0,x1) -> - To.Outcometree.Oide_apply - ((copy_out_ident x0), - (copy_out_ident x1)) - | From.Outcometree.Oide_dot (x0,x1) -> - To.Outcometree.Oide_dot - ((copy_out_ident x0), x1) - | From.Outcometree.Oide_ident x0 -> To.Outcometree.Oide_ident x0 - -let rec copy_toplevel_phrase : - From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = - function - | From.Parsetree.Ptop_def x0 -> - To.Parsetree.Ptop_def (copy_structure x0) - | From.Parsetree.Ptop_dir (x0,x1) -> - To.Parsetree.Ptop_dir - (x0, (copy_directive_argument x1)) - -and copy_directive_argument : - From.Parsetree.directive_argument -> To.Parsetree.directive_argument = + (fun x -> + let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1))) + x0) + | Ast_406.Outcometree.Oval_string (x0, x1, x2) -> + Ast_407.Outcometree.Oval_string (x0, x1, (copy_out_string x2)) + | Ast_406.Outcometree.Oval_stuff x0 -> Ast_407.Outcometree.Oval_stuff x0 + | Ast_406.Outcometree.Oval_tuple x0 -> + Ast_407.Outcometree.Oval_tuple (List.map copy_out_value x0) + | Ast_406.Outcometree.Oval_variant (x0, x1) -> + Ast_407.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1)) +and copy_out_string : + Ast_406.Outcometree.out_string -> Ast_407.Outcometree.out_string = function - | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none - | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 - | From.Parsetree.Pdir_int (x0,x1) -> - To.Parsetree.Pdir_int (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pdir_ident x0 -> - To.Parsetree.Pdir_ident (copy_longident x0) - | From.Parsetree.Pdir_bool x0 -> - To.Parsetree.Pdir_bool (copy_bool x0) - -let copy_out_type_extension : - From.Outcometree.out_type_extension -> To.Outcometree.out_type_extension = - fun - { From.Outcometree.otyext_name = otyext_name; - From.Outcometree.otyext_params = otyext_params; - From.Outcometree.otyext_constructors = otyext_constructors; - From.Outcometree.otyext_private = otyext_private } - -> - { - To.Outcometree.otyext_name = otyext_name; - To.Outcometree.otyext_params = - (List.map (fun x -> x) otyext_params); - To.Outcometree.otyext_constructors = - (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) - otyext_constructors); - To.Outcometree.otyext_private = - (copy_private_flag otyext_private) - } - -let copy_cases x = List.map copy_case x -let copy_pat = copy_pattern -let copy_expr = copy_expression -let copy_typ = copy_core_type + | Ast_406.Outcometree.Ostr_string -> Ast_407.Outcometree.Ostr_string + | Ast_406.Outcometree.Ostr_bytes -> Ast_407.Outcometree.Ostr_bytes +and copy_out_ident : + Ast_406.Outcometree.out_ident -> Ast_407.Outcometree.out_ident = + function + | Ast_406.Outcometree.Oide_apply (x0, x1) -> + Ast_407.Outcometree.Oide_apply + ((copy_out_ident x0), (copy_out_ident x1)) + | Ast_406.Outcometree.Oide_dot (x0, x1) -> + Ast_407.Outcometree.Oide_dot ((copy_out_ident x0), x1) + | Ast_406.Outcometree.Oide_ident x0 -> Ast_407.Outcometree.Oide_ident x0 diff --git a/src/vendored-omp/src/migrate_parsetree_407_406.ml b/src/vendored-omp/src/migrate_parsetree_407_406.ml index 67831d72c..15bd79c03 100644 --- a/src/vendored-omp/src/migrate_parsetree_407_406.ml +++ b/src/vendored-omp/src/migrate_parsetree_407_406.ml @@ -15,116 +15,3 @@ include Migrate_parsetree_407_406_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - (*$*) - } as mapper) -> - let module R = Migrate_parsetree_406_407_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_407_406_migrate.ml b/src/vendored-omp/src/migrate_parsetree_407_406_migrate.ml index 047c8c58a..b17b28e0c 100644 --- a/src/vendored-omp/src/migrate_parsetree_407_406_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_407_406_migrate.ml @@ -1,1730 +1,305 @@ -(**************************************************************************) -(* *) -(* OCaml Migrate Parsetree *) -(* *) -(* Frédéric Bour *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2017 Institut National de Recherche en Informatique et *) -(* en Automatique (INRIA). *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - +open Stdlib0 module From = Ast_407 module To = Ast_406 - -let rec copy_expression : - From.Parsetree.expression -> To.Parsetree.expression = - fun - { From.Parsetree.pexp_desc = pexp_desc; - From.Parsetree.pexp_loc = pexp_loc; - From.Parsetree.pexp_attributes = pexp_attributes } - -> - { - To.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - To.Parsetree.pexp_loc = (copy_location pexp_loc); - To.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } - -and copy_expression_desc : - From.Parsetree.expression_desc -> To.Parsetree.expression_desc = - function - | From.Parsetree.Pexp_ident x0 -> - To.Parsetree.Pexp_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_constant x0 -> - To.Parsetree.Pexp_constant (copy_constant x0) - | From.Parsetree.Pexp_let (x0,x1,x2) -> - To.Parsetree.Pexp_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_expression x2)) - | From.Parsetree.Pexp_function x0 -> - To.Parsetree.Pexp_function - (List.map copy_case x0) - | From.Parsetree.Pexp_fun (x0,x1,x2,x3) -> - To.Parsetree.Pexp_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_expression x3)) - | From.Parsetree.Pexp_apply (x0,x1) -> - To.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pexp_match (x0,x1) -> - To.Parsetree.Pexp_match - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_try (x0,x1) -> - To.Parsetree.Pexp_try - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_tuple x0 -> - To.Parsetree.Pexp_tuple - (List.map copy_expression x0) - | From.Parsetree.Pexp_construct (x0,x1) -> - To.Parsetree.Pexp_construct - ((copy_loc copy_longident x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_variant (x0,x1) -> - To.Parsetree.Pexp_variant - ((copy_label x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_record (x0,x1) -> - To.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_expression x1))) x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_field (x0,x1) -> - To.Parsetree.Pexp_field - ((copy_expression x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pexp_setfield (x0,x1,x2) -> - To.Parsetree.Pexp_setfield - ((copy_expression x0), - (copy_loc copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_array x0 -> - To.Parsetree.Pexp_array - (List.map copy_expression x0) - | From.Parsetree.Pexp_ifthenelse (x0,x1,x2) -> - To.Parsetree.Pexp_ifthenelse - ((copy_expression x0), - (copy_expression x1), - (copy_option copy_expression x2)) - | From.Parsetree.Pexp_sequence (x0,x1) -> - To.Parsetree.Pexp_sequence - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_while (x0,x1) -> - To.Parsetree.Pexp_while - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_for (x0,x1,x2,x3,x4) -> - To.Parsetree.Pexp_for - ((copy_pattern x0), - (copy_expression x1), - (copy_expression x2), - (copy_direction_flag x3), - (copy_expression x4)) - | From.Parsetree.Pexp_constraint (x0,x1) -> - To.Parsetree.Pexp_constraint - ((copy_expression x0), - (copy_core_type x1)) - | From.Parsetree.Pexp_coerce (x0,x1,x2) -> - To.Parsetree.Pexp_coerce - ((copy_expression x0), - (copy_option copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Pexp_send (x0,x1) -> - To.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc (fun x -> x) x1)) - | From.Parsetree.Pexp_new x0 -> - To.Parsetree.Pexp_new - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_setinstvar (x0,x1) -> - To.Parsetree.Pexp_setinstvar - ((copy_loc (fun x -> x) x0), - (copy_expression x1)) - | From.Parsetree.Pexp_override x0 -> - To.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_expression x1))) x0) - | From.Parsetree.Pexp_letmodule (x0,x1,x2) -> - To.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> x) x0), - (copy_module_expr x1), - (copy_expression x2)) - | From.Parsetree.Pexp_letexception (x0,x1) -> - To.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), - (copy_expression x1)) - | From.Parsetree.Pexp_assert x0 -> - To.Parsetree.Pexp_assert (copy_expression x0) - | From.Parsetree.Pexp_lazy x0 -> - To.Parsetree.Pexp_lazy (copy_expression x0) - | From.Parsetree.Pexp_poly (x0,x1) -> - To.Parsetree.Pexp_poly - ((copy_expression x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pexp_object x0 -> - To.Parsetree.Pexp_object - (copy_class_structure x0) - | From.Parsetree.Pexp_newtype (x0,x1) -> - To.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | From.Parsetree.Pexp_pack x0 -> - To.Parsetree.Pexp_pack (copy_module_expr x0) - | From.Parsetree.Pexp_open (x0,x1,x2) -> - To.Parsetree.Pexp_open - ((copy_override_flag x0), - (copy_loc copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_extension x0 -> - To.Parsetree.Pexp_extension (copy_extension x0) - | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable - -and copy_direction_flag : - From.Asttypes.direction_flag -> To.Asttypes.direction_flag = - function - | From.Asttypes.Upto -> To.Asttypes.Upto - | From.Asttypes.Downto -> To.Asttypes.Downto - -and copy_case : - From.Parsetree.case -> To.Parsetree.case = - fun - { From.Parsetree.pc_lhs = pc_lhs; - From.Parsetree.pc_guard = pc_guard; - From.Parsetree.pc_rhs = pc_rhs } - -> - { - To.Parsetree.pc_lhs = (copy_pattern pc_lhs); - To.Parsetree.pc_guard = - (copy_option copy_expression pc_guard); - To.Parsetree.pc_rhs = (copy_expression pc_rhs) - } - -and copy_value_binding : - From.Parsetree.value_binding -> To.Parsetree.value_binding = - fun - { From.Parsetree.pvb_pat = pvb_pat; - From.Parsetree.pvb_expr = pvb_expr; - From.Parsetree.pvb_attributes = pvb_attributes; - From.Parsetree.pvb_loc = pvb_loc } - -> - { - To.Parsetree.pvb_pat = (copy_pattern pvb_pat); - To.Parsetree.pvb_expr = - (copy_expression pvb_expr); - To.Parsetree.pvb_attributes = - (copy_attributes pvb_attributes); - To.Parsetree.pvb_loc = (copy_location pvb_loc) - } - -and copy_pattern : - From.Parsetree.pattern -> To.Parsetree.pattern = - fun - { From.Parsetree.ppat_desc = ppat_desc; - From.Parsetree.ppat_loc = ppat_loc; - From.Parsetree.ppat_attributes = ppat_attributes } - -> - { - To.Parsetree.ppat_desc = - (copy_pattern_desc ppat_desc); - To.Parsetree.ppat_loc = (copy_location ppat_loc); - To.Parsetree.ppat_attributes = - (copy_attributes ppat_attributes) - } - -and copy_pattern_desc : - From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc = - function - | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any - | From.Parsetree.Ppat_var x0 -> - To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_alias (x0,x1) -> - To.Parsetree.Ppat_alias - ((copy_pattern x0), - (copy_loc (fun x -> x) x1)) - | From.Parsetree.Ppat_constant x0 -> - To.Parsetree.Ppat_constant (copy_constant x0) - | From.Parsetree.Ppat_interval (x0,x1) -> - To.Parsetree.Ppat_interval - ((copy_constant x0), - (copy_constant x1)) - | From.Parsetree.Ppat_tuple x0 -> - To.Parsetree.Ppat_tuple - (List.map copy_pattern x0) - | From.Parsetree.Ppat_construct (x0,x1) -> - To.Parsetree.Ppat_construct - ((copy_loc copy_longident x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_variant (x0,x1) -> - To.Parsetree.Ppat_variant - ((copy_label x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_record (x0,x1) -> - To.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ppat_array x0 -> - To.Parsetree.Ppat_array - (List.map copy_pattern x0) - | From.Parsetree.Ppat_or (x0,x1) -> - To.Parsetree.Ppat_or - ((copy_pattern x0), - (copy_pattern x1)) - | From.Parsetree.Ppat_constraint (x0,x1) -> - To.Parsetree.Ppat_constraint - ((copy_pattern x0), - (copy_core_type x1)) - | From.Parsetree.Ppat_type x0 -> - To.Parsetree.Ppat_type - (copy_loc copy_longident x0) - | From.Parsetree.Ppat_lazy x0 -> - To.Parsetree.Ppat_lazy (copy_pattern x0) - | From.Parsetree.Ppat_unpack x0 -> - To.Parsetree.Ppat_unpack - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_exception x0 -> - To.Parsetree.Ppat_exception (copy_pattern x0) - | From.Parsetree.Ppat_extension x0 -> - To.Parsetree.Ppat_extension (copy_extension x0) - | From.Parsetree.Ppat_open (x0,x1) -> - To.Parsetree.Ppat_open - ((copy_loc copy_longident x0), - (copy_pattern x1)) - -and copy_core_type : - From.Parsetree.core_type -> To.Parsetree.core_type = - fun - { From.Parsetree.ptyp_desc = ptyp_desc; - From.Parsetree.ptyp_loc = ptyp_loc; - From.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - To.Parsetree.ptyp_desc = - (copy_core_type_desc ptyp_desc); - To.Parsetree.ptyp_loc = (copy_location ptyp_loc); - To.Parsetree.ptyp_attributes = - (copy_attributes ptyp_attributes) - } - -and copy_core_type_desc : - From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = - function - | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any - | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 - | From.Parsetree.Ptyp_arrow (x0,x1,x2) -> - To.Parsetree.Ptyp_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Ptyp_tuple x0 -> - To.Parsetree.Ptyp_tuple - (List.map copy_core_type x0) - | From.Parsetree.Ptyp_constr (x0,x1) -> - To.Parsetree.Ptyp_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_object (x0,x1) -> - To.Parsetree.Ptyp_object - (List.map copy_object_field x0, - copy_closed_flag x1) - | From.Parsetree.Ptyp_class (x0,x1) -> - To.Parsetree.Ptyp_class - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_alias (x0,x1) -> - To.Parsetree.Ptyp_alias - ((copy_core_type x0), x1) - | From.Parsetree.Ptyp_variant (x0,x1,x2) -> - To.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), - (copy_closed_flag x1), - (copy_option (fun x -> List.map copy_label x) x2)) - | From.Parsetree.Ptyp_poly (x0,x1) -> - To.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), (copy_core_type x1)) - | From.Parsetree.Ptyp_package x0 -> - To.Parsetree.Ptyp_package (copy_package_type x0) - | From.Parsetree.Ptyp_extension x0 -> - To.Parsetree.Ptyp_extension (copy_extension x0) - -and copy_package_type : - From.Parsetree.package_type -> To.Parsetree.package_type = - fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_core_type x1))) x1)) - -and copy_row_field : - From.Parsetree.row_field -> To.Parsetree.row_field = - function - | From.Parsetree.Rtag (x0,x1,x2,x3) -> - To.Parsetree.Rtag - (copy_loc copy_label x0, - copy_attributes x1, copy_bool x2, - List.map copy_core_type x3) - | From.Parsetree.Rinherit x0 -> - To.Parsetree.Rinherit (copy_core_type x0) - -and copy_object_field : - From.Parsetree.object_field -> To.Parsetree.object_field = - function - | From.Parsetree.Otag (x0,x1,x2) -> - To.Parsetree.Otag (copy_loc (fun x -> x) x0, - copy_attributes x1, - copy_core_type x2) - | From.Parsetree.Oinherit x -> To.Parsetree.Oinherit (copy_core_type x) - -and copy_attributes : - From.Parsetree.attributes -> To.Parsetree.attributes = - fun x -> List.map copy_attribute x - -and copy_attribute : - From.Parsetree.attribute -> To.Parsetree.attribute = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_payload : - From.Parsetree.payload -> To.Parsetree.payload = - function - | From.Parsetree.PStr x0 -> - To.Parsetree.PStr (copy_structure x0) - | From.Parsetree.PSig x0 -> - To.Parsetree.PSig (copy_signature x0) - | From.Parsetree.PTyp x0 -> - To.Parsetree.PTyp (copy_core_type x0) - | From.Parsetree.PPat (x0,x1) -> - To.Parsetree.PPat - ((copy_pattern x0), - (copy_option copy_expression x1)) - -and copy_structure : - From.Parsetree.structure -> To.Parsetree.structure = - fun x -> List.map copy_structure_item x - -and copy_structure_item : - From.Parsetree.structure_item -> To.Parsetree.structure_item = - fun - { From.Parsetree.pstr_desc = pstr_desc; - From.Parsetree.pstr_loc = pstr_loc } - -> - { - To.Parsetree.pstr_desc = - (copy_structure_item_desc pstr_desc); - To.Parsetree.pstr_loc = (copy_location pstr_loc) - } - -and copy_structure_item_desc : - From.Parsetree.structure_item_desc -> - To.Parsetree.structure_item_desc - = - function - | From.Parsetree.Pstr_eval (x0,x1) -> - To.Parsetree.Pstr_eval - ((copy_expression x0), - (copy_attributes x1)) - | From.Parsetree.Pstr_value (x0,x1) -> - To.Parsetree.Pstr_value - ((copy_rec_flag x0), - (List.map copy_value_binding x1)) - | From.Parsetree.Pstr_primitive x0 -> - To.Parsetree.Pstr_primitive - (copy_value_description x0) - | From.Parsetree.Pstr_type (x0,x1) -> - To.Parsetree.Pstr_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Pstr_typext x0 -> - To.Parsetree.Pstr_typext - (copy_type_extension x0) - | From.Parsetree.Pstr_exception x0 -> - To.Parsetree.Pstr_exception - (copy_extension_constructor x0) - | From.Parsetree.Pstr_module x0 -> - To.Parsetree.Pstr_module - (copy_module_binding x0) - | From.Parsetree.Pstr_recmodule x0 -> - To.Parsetree.Pstr_recmodule - (List.map copy_module_binding x0) - | From.Parsetree.Pstr_modtype x0 -> - To.Parsetree.Pstr_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Pstr_open x0 -> - To.Parsetree.Pstr_open - (copy_open_description x0) - | From.Parsetree.Pstr_class x0 -> - To.Parsetree.Pstr_class - (List.map copy_class_declaration x0) - | From.Parsetree.Pstr_class_type x0 -> - To.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Pstr_include x0 -> - To.Parsetree.Pstr_include - (copy_include_declaration x0) - | From.Parsetree.Pstr_attribute x0 -> - To.Parsetree.Pstr_attribute (copy_attribute x0) - | From.Parsetree.Pstr_extension (x0,x1) -> - To.Parsetree.Pstr_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_include_declaration : - From.Parsetree.include_declaration -> - To.Parsetree.include_declaration - = - fun x -> - copy_include_infos copy_module_expr x - -and copy_class_declaration : - From.Parsetree.class_declaration -> To.Parsetree.class_declaration +let rec copy_out_type_extension : + Ast_407.Outcometree.out_type_extension -> + Ast_406.Outcometree.out_type_extension = - fun x -> - copy_class_infos copy_class_expr x - -and copy_class_expr : - From.Parsetree.class_expr -> To.Parsetree.class_expr = fun - { From.Parsetree.pcl_desc = pcl_desc; - From.Parsetree.pcl_loc = pcl_loc; - From.Parsetree.pcl_attributes = pcl_attributes } - -> + { Ast_407.Outcometree.otyext_name = otyext_name; + Ast_407.Outcometree.otyext_params = otyext_params; + Ast_407.Outcometree.otyext_constructors = otyext_constructors; + Ast_407.Outcometree.otyext_private = otyext_private } + -> { - To.Parsetree.pcl_desc = - (copy_class_expr_desc pcl_desc); - To.Parsetree.pcl_loc = (copy_location pcl_loc); - To.Parsetree.pcl_attributes = - (copy_attributes pcl_attributes) - } - -and copy_class_expr_desc : - From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = - function - | From.Parsetree.Pcl_constr (x0,x1) -> - To.Parsetree.Pcl_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcl_structure x0 -> - To.Parsetree.Pcl_structure - (copy_class_structure x0) - | From.Parsetree.Pcl_fun (x0,x1,x2,x3) -> - To.Parsetree.Pcl_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_class_expr x3)) - | From.Parsetree.Pcl_apply (x0,x1) -> - To.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pcl_let (x0,x1,x2) -> - To.Parsetree.Pcl_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_class_expr x2)) - | From.Parsetree.Pcl_constraint (x0,x1) -> - To.Parsetree.Pcl_constraint - ((copy_class_expr x0), - (copy_class_type x1)) - | From.Parsetree.Pcl_extension x0 -> - To.Parsetree.Pcl_extension (copy_extension x0) - | From.Parsetree.Pcl_open (ovf, loc, ce) -> - To.Parsetree.Pcl_open (copy_override_flag ovf, - copy_loc copy_longident loc, - copy_class_expr ce) - -and copy_class_structure : - From.Parsetree.class_structure -> To.Parsetree.class_structure = - fun - { From.Parsetree.pcstr_self = pcstr_self; - From.Parsetree.pcstr_fields = pcstr_fields } - -> - { - To.Parsetree.pcstr_self = - (copy_pattern pcstr_self); - To.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } - -and copy_class_field : - From.Parsetree.class_field -> To.Parsetree.class_field = - fun - { From.Parsetree.pcf_desc = pcf_desc; - From.Parsetree.pcf_loc = pcf_loc; - From.Parsetree.pcf_attributes = pcf_attributes } - -> - { - To.Parsetree.pcf_desc = - (copy_class_field_desc pcf_desc); - To.Parsetree.pcf_loc = (copy_location pcf_loc); - To.Parsetree.pcf_attributes = - (copy_attributes pcf_attributes) - } - -and copy_class_field_desc : - From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = - function - | From.Parsetree.Pcf_inherit (x0,x1,x2) -> - To.Parsetree.Pcf_inherit - ((copy_override_flag x0), - (copy_class_expr x1), - (copy_option (copy_loc (fun x -> x)) x2)) - | From.Parsetree.Pcf_val x0 -> - To.Parsetree.Pcf_val - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_method x0 -> - To.Parsetree.Pcf_method - (let (x0,x1,x2) = x0 in - ((copy_loc (fun x -> x) x0), - (copy_private_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_constraint x0 -> - To.Parsetree.Pcf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pcf_initializer x0 -> - To.Parsetree.Pcf_initializer - (copy_expression x0) - | From.Parsetree.Pcf_attribute x0 -> - To.Parsetree.Pcf_attribute (copy_attribute x0) - | From.Parsetree.Pcf_extension x0 -> - To.Parsetree.Pcf_extension (copy_extension x0) - -and copy_class_field_kind : - From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = - function - | From.Parsetree.Cfk_virtual x0 -> - To.Parsetree.Cfk_virtual (copy_core_type x0) - | From.Parsetree.Cfk_concrete (x0,x1) -> - To.Parsetree.Cfk_concrete - ((copy_override_flag x0), - (copy_expression x1)) - -and copy_module_binding : - From.Parsetree.module_binding -> To.Parsetree.module_binding = - fun - { From.Parsetree.pmb_name = pmb_name; - From.Parsetree.pmb_expr = pmb_expr; - From.Parsetree.pmb_attributes = pmb_attributes; - From.Parsetree.pmb_loc = pmb_loc } - -> - { - To.Parsetree.pmb_name = - (copy_loc (fun x -> x) pmb_name); - To.Parsetree.pmb_expr = - (copy_module_expr pmb_expr); - To.Parsetree.pmb_attributes = - (copy_attributes pmb_attributes); - To.Parsetree.pmb_loc = (copy_location pmb_loc) - } - -and copy_module_expr : - From.Parsetree.module_expr -> To.Parsetree.module_expr = - fun - { From.Parsetree.pmod_desc = pmod_desc; - From.Parsetree.pmod_loc = pmod_loc; - From.Parsetree.pmod_attributes = pmod_attributes } - -> - { - To.Parsetree.pmod_desc = - (copy_module_expr_desc pmod_desc); - To.Parsetree.pmod_loc = (copy_location pmod_loc); - To.Parsetree.pmod_attributes = - (copy_attributes pmod_attributes) - } - -and copy_module_expr_desc : - From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = - function - | From.Parsetree.Pmod_ident x0 -> - To.Parsetree.Pmod_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmod_structure x0 -> - To.Parsetree.Pmod_structure (copy_structure x0) - | From.Parsetree.Pmod_functor (x0,x1,x2) -> - To.Parsetree.Pmod_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_expr x2)) - | From.Parsetree.Pmod_apply (x0,x1) -> - To.Parsetree.Pmod_apply - ((copy_module_expr x0), - (copy_module_expr x1)) - | From.Parsetree.Pmod_constraint (x0,x1) -> - To.Parsetree.Pmod_constraint - ((copy_module_expr x0), - (copy_module_type x1)) - | From.Parsetree.Pmod_unpack x0 -> - To.Parsetree.Pmod_unpack (copy_expression x0) - | From.Parsetree.Pmod_extension x0 -> - To.Parsetree.Pmod_extension (copy_extension x0) - -and copy_module_type : - From.Parsetree.module_type -> To.Parsetree.module_type = - fun - { From.Parsetree.pmty_desc = pmty_desc; - From.Parsetree.pmty_loc = pmty_loc; - From.Parsetree.pmty_attributes = pmty_attributes } - -> - { - To.Parsetree.pmty_desc = - (copy_module_type_desc pmty_desc); - To.Parsetree.pmty_loc = (copy_location pmty_loc); - To.Parsetree.pmty_attributes = - (copy_attributes pmty_attributes) - } - -and copy_module_type_desc : - From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = - function - | From.Parsetree.Pmty_ident x0 -> - To.Parsetree.Pmty_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmty_signature x0 -> - To.Parsetree.Pmty_signature (copy_signature x0) - | From.Parsetree.Pmty_functor (x0,x1,x2) -> - To.Parsetree.Pmty_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_type x2)) - | From.Parsetree.Pmty_with (x0,x1) -> - To.Parsetree.Pmty_with - ((copy_module_type x0), - (List.map copy_with_constraint x1)) - | From.Parsetree.Pmty_typeof x0 -> - To.Parsetree.Pmty_typeof (copy_module_expr x0) - | From.Parsetree.Pmty_extension x0 -> - To.Parsetree.Pmty_extension (copy_extension x0) - | From.Parsetree.Pmty_alias x0 -> - To.Parsetree.Pmty_alias - (copy_loc copy_longident x0) - -and copy_with_constraint : - From.Parsetree.with_constraint -> To.Parsetree.with_constraint = - function - | From.Parsetree.Pwith_type (x0,x1) -> - To.Parsetree.Pwith_type - ((copy_loc copy_longident x0), - (copy_type_declaration x1)) - | From.Parsetree.Pwith_module (x0,x1) -> - To.Parsetree.Pwith_module - ((copy_loc copy_longident x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pwith_typesubst (x0, x1) -> - To.Parsetree.Pwith_typesubst - (copy_loc copy_longident x0, copy_type_declaration x1) - | From.Parsetree.Pwith_modsubst (x0,x1) -> - To.Parsetree.Pwith_modsubst - (copy_loc copy_longident x0, copy_loc copy_longident x1) - -and copy_signature : - From.Parsetree.signature -> To.Parsetree.signature = - fun x -> List.map copy_signature_item x - -and copy_signature_item : - From.Parsetree.signature_item -> To.Parsetree.signature_item = - fun - { From.Parsetree.psig_desc = psig_desc; - From.Parsetree.psig_loc = psig_loc } - -> - { - To.Parsetree.psig_desc = - (copy_signature_item_desc psig_desc); - To.Parsetree.psig_loc = (copy_location psig_loc) - } - -and copy_signature_item_desc : - From.Parsetree.signature_item_desc -> - To.Parsetree.signature_item_desc - = - function - | From.Parsetree.Psig_value x0 -> - To.Parsetree.Psig_value - (copy_value_description x0) - | From.Parsetree.Psig_type (x0,x1) -> - To.Parsetree.Psig_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Psig_typext x0 -> - To.Parsetree.Psig_typext - (copy_type_extension x0) - | From.Parsetree.Psig_exception x0 -> - To.Parsetree.Psig_exception - (copy_extension_constructor x0) - | From.Parsetree.Psig_module x0 -> - To.Parsetree.Psig_module - (copy_module_declaration x0) - | From.Parsetree.Psig_recmodule x0 -> - To.Parsetree.Psig_recmodule - (List.map copy_module_declaration x0) - | From.Parsetree.Psig_modtype x0 -> - To.Parsetree.Psig_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Psig_open x0 -> - To.Parsetree.Psig_open - (copy_open_description x0) - | From.Parsetree.Psig_include x0 -> - To.Parsetree.Psig_include - (copy_include_description x0) - | From.Parsetree.Psig_class x0 -> - To.Parsetree.Psig_class - (List.map copy_class_description x0) - | From.Parsetree.Psig_class_type x0 -> - To.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Psig_attribute x0 -> - To.Parsetree.Psig_attribute (copy_attribute x0) - | From.Parsetree.Psig_extension (x0,x1) -> - To.Parsetree.Psig_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_class_type_declaration : - From.Parsetree.class_type_declaration -> - To.Parsetree.class_type_declaration - = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_description : - From.Parsetree.class_description -> To.Parsetree.class_description - = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_type : - From.Parsetree.class_type -> To.Parsetree.class_type = - fun - { From.Parsetree.pcty_desc = pcty_desc; - From.Parsetree.pcty_loc = pcty_loc; - From.Parsetree.pcty_attributes = pcty_attributes } - -> - { - To.Parsetree.pcty_desc = - (copy_class_type_desc pcty_desc); - To.Parsetree.pcty_loc = (copy_location pcty_loc); - To.Parsetree.pcty_attributes = - (copy_attributes pcty_attributes) - } - -and copy_class_type_desc : - From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = - function - | From.Parsetree.Pcty_constr (x0,x1) -> - To.Parsetree.Pcty_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcty_signature x0 -> - To.Parsetree.Pcty_signature - (copy_class_signature x0) - | From.Parsetree.Pcty_arrow (x0,x1,x2) -> - To.Parsetree.Pcty_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_class_type x2)) - | From.Parsetree.Pcty_extension x0 -> - To.Parsetree.Pcty_extension (copy_extension x0) - | From.Parsetree.Pcty_open (ovf, loc, cty) -> - To.Parsetree.Pcty_open (copy_override_flag ovf, - copy_loc copy_longident loc, - copy_class_type cty) - -and copy_class_signature : - From.Parsetree.class_signature -> To.Parsetree.class_signature = - fun - { From.Parsetree.pcsig_self = pcsig_self; - From.Parsetree.pcsig_fields = pcsig_fields } - -> - { - To.Parsetree.pcsig_self = - (copy_core_type pcsig_self); - To.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } - -and copy_class_type_field : - From.Parsetree.class_type_field -> To.Parsetree.class_type_field = - fun - { From.Parsetree.pctf_desc = pctf_desc; - From.Parsetree.pctf_loc = pctf_loc; - From.Parsetree.pctf_attributes = pctf_attributes } - -> - { - To.Parsetree.pctf_desc = - (copy_class_type_field_desc pctf_desc); - To.Parsetree.pctf_loc = (copy_location pctf_loc); - To.Parsetree.pctf_attributes = - (copy_attributes pctf_attributes) - } - -and copy_class_type_field_desc : - From.Parsetree.class_type_field_desc -> - To.Parsetree.class_type_field_desc - = - function - | From.Parsetree.Pctf_inherit x0 -> - To.Parsetree.Pctf_inherit (copy_class_type x0) - | From.Parsetree.Pctf_val x0 -> - To.Parsetree.Pctf_val - (let (x0,x1,x2,x3) = x0 in - (copy_loc (fun x -> x) x0, (copy_mutable_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_method x0 -> - To.Parsetree.Pctf_method - (let (x0,x1,x2,x3) = x0 in - (copy_loc (fun x -> x) x0, (copy_private_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_constraint x0 -> - To.Parsetree.Pctf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pctf_attribute x0 -> - To.Parsetree.Pctf_attribute (copy_attribute x0) - | From.Parsetree.Pctf_extension x0 -> - To.Parsetree.Pctf_extension (copy_extension x0) - -and copy_extension : - From.Parsetree.extension -> To.Parsetree.extension = - fun x -> - let (x0,x1) = x in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.class_infos -> 'g0 To.Parsetree.class_infos - = - fun f0 -> - fun - { From.Parsetree.pci_virt = pci_virt; - From.Parsetree.pci_params = pci_params; - From.Parsetree.pci_name = pci_name; - From.Parsetree.pci_expr = pci_expr; - From.Parsetree.pci_loc = pci_loc; - From.Parsetree.pci_attributes = pci_attributes } - -> - { - To.Parsetree.pci_virt = - (copy_virtual_flag pci_virt); - To.Parsetree.pci_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) pci_params); - To.Parsetree.pci_name = - (copy_loc (fun x -> x) pci_name); - To.Parsetree.pci_expr = (f0 pci_expr); - To.Parsetree.pci_loc = (copy_location pci_loc); - To.Parsetree.pci_attributes = - (copy_attributes pci_attributes) - } - -and copy_virtual_flag : - From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = - function - | From.Asttypes.Virtual -> To.Asttypes.Virtual - | From.Asttypes.Concrete -> To.Asttypes.Concrete - -and copy_include_description : - From.Parsetree.include_description -> - To.Parsetree.include_description - = - fun x -> - copy_include_infos copy_module_type x - -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.include_infos -> - 'g0 To.Parsetree.include_infos - = - fun f0 -> - fun - { From.Parsetree.pincl_mod = pincl_mod; - From.Parsetree.pincl_loc = pincl_loc; - From.Parsetree.pincl_attributes = pincl_attributes } - -> - { - To.Parsetree.pincl_mod = (f0 pincl_mod); - To.Parsetree.pincl_loc = (copy_location pincl_loc); - To.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } - -and copy_open_description : - From.Parsetree.open_description -> To.Parsetree.open_description = - fun - { From.Parsetree.popen_lid = popen_lid; - From.Parsetree.popen_override = popen_override; - From.Parsetree.popen_loc = popen_loc; - From.Parsetree.popen_attributes = popen_attributes } - -> - { - To.Parsetree.popen_lid = - (copy_loc copy_longident popen_lid); - To.Parsetree.popen_override = - (copy_override_flag popen_override); - To.Parsetree.popen_loc = (copy_location popen_loc); - To.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } - -and copy_override_flag : - From.Asttypes.override_flag -> To.Asttypes.override_flag = - function - | From.Asttypes.Override -> To.Asttypes.Override - | From.Asttypes.Fresh -> To.Asttypes.Fresh - -and copy_module_type_declaration : - From.Parsetree.module_type_declaration -> - To.Parsetree.module_type_declaration - = - fun - { From.Parsetree.pmtd_name = pmtd_name; - From.Parsetree.pmtd_type = pmtd_type; - From.Parsetree.pmtd_attributes = pmtd_attributes; - From.Parsetree.pmtd_loc = pmtd_loc } - -> - { - To.Parsetree.pmtd_name = - (copy_loc (fun x -> x) pmtd_name); - To.Parsetree.pmtd_type = - (copy_option copy_module_type pmtd_type); - To.Parsetree.pmtd_attributes = - (copy_attributes pmtd_attributes); - To.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } - -and copy_module_declaration : - From.Parsetree.module_declaration -> - To.Parsetree.module_declaration - = - fun - { From.Parsetree.pmd_name = pmd_name; - From.Parsetree.pmd_type = pmd_type; - From.Parsetree.pmd_attributes = pmd_attributes; - From.Parsetree.pmd_loc = pmd_loc } - -> - { - To.Parsetree.pmd_name = - (copy_loc (fun x -> x) pmd_name); - To.Parsetree.pmd_type = - (copy_module_type pmd_type); - To.Parsetree.pmd_attributes = - (copy_attributes pmd_attributes); - To.Parsetree.pmd_loc = (copy_location pmd_loc) - } - -and copy_type_extension : - From.Parsetree.type_extension -> To.Parsetree.type_extension = - fun - { From.Parsetree.ptyext_path = ptyext_path; - From.Parsetree.ptyext_params = ptyext_params; - From.Parsetree.ptyext_constructors = ptyext_constructors; - From.Parsetree.ptyext_private = ptyext_private; - From.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - To.Parsetree.ptyext_path = - (copy_loc copy_longident ptyext_path); - To.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptyext_params); - To.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor - ptyext_constructors); - To.Parsetree.ptyext_private = - (copy_private_flag ptyext_private); - To.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } - -and copy_extension_constructor : - From.Parsetree.extension_constructor -> - To.Parsetree.extension_constructor - = - fun - { From.Parsetree.pext_name = pext_name; - From.Parsetree.pext_kind = pext_kind; - From.Parsetree.pext_loc = pext_loc; - From.Parsetree.pext_attributes = pext_attributes } - -> - { - To.Parsetree.pext_name = - (copy_loc (fun x -> x) pext_name); - To.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - To.Parsetree.pext_loc = (copy_location pext_loc); - To.Parsetree.pext_attributes = - (copy_attributes pext_attributes) - } - -and copy_extension_constructor_kind : - From.Parsetree.extension_constructor_kind -> - To.Parsetree.extension_constructor_kind - = - function - | From.Parsetree.Pext_decl (x0,x1) -> - To.Parsetree.Pext_decl - ((copy_constructor_arguments x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pext_rebind x0 -> - To.Parsetree.Pext_rebind - (copy_loc copy_longident x0) - -and copy_type_declaration : - From.Parsetree.type_declaration -> To.Parsetree.type_declaration = - fun - { From.Parsetree.ptype_name = ptype_name; - From.Parsetree.ptype_params = ptype_params; - From.Parsetree.ptype_cstrs = ptype_cstrs; - From.Parsetree.ptype_kind = ptype_kind; - From.Parsetree.ptype_private = ptype_private; - From.Parsetree.ptype_manifest = ptype_manifest; - From.Parsetree.ptype_attributes = ptype_attributes; - From.Parsetree.ptype_loc = ptype_loc } - -> - { - To.Parsetree.ptype_name = - (copy_loc (fun x -> x) ptype_name); - To.Parsetree.ptype_params = + Ast_406.Outcometree.otyext_name = otyext_name; + Ast_406.Outcometree.otyext_params = + (List.map (fun x -> x) otyext_params); + Ast_406.Outcometree.otyext_constructors = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptype_params); - To.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0,x1,x2) = x in - ((copy_core_type x0), - (copy_core_type x1), - (copy_location x2))) ptype_cstrs); - To.Parsetree.ptype_kind = - (copy_type_kind ptype_kind); - To.Parsetree.ptype_private = - (copy_private_flag ptype_private); - To.Parsetree.ptype_manifest = - (copy_option copy_core_type ptype_manifest); - To.Parsetree.ptype_attributes = - (copy_attributes ptype_attributes); - To.Parsetree.ptype_loc = (copy_location ptype_loc) - } - -and copy_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = - function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - -and copy_type_kind : - From.Parsetree.type_kind -> To.Parsetree.type_kind = - function - | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract - | From.Parsetree.Ptype_variant x0 -> - To.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | From.Parsetree.Ptype_record x0 -> - To.Parsetree.Ptype_record - (List.map copy_label_declaration x0) - | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open - -and copy_constructor_declaration : - From.Parsetree.constructor_declaration -> - To.Parsetree.constructor_declaration - = - fun - { From.Parsetree.pcd_name = pcd_name; - From.Parsetree.pcd_args = pcd_args; - From.Parsetree.pcd_res = pcd_res; - From.Parsetree.pcd_loc = pcd_loc; - From.Parsetree.pcd_attributes = pcd_attributes } - -> - { - To.Parsetree.pcd_name = - (copy_loc (fun x -> x) pcd_name); - To.Parsetree.pcd_args = - (copy_constructor_arguments pcd_args); - To.Parsetree.pcd_res = - (copy_option copy_core_type pcd_res); - To.Parsetree.pcd_loc = (copy_location pcd_loc); - To.Parsetree.pcd_attributes = - (copy_attributes pcd_attributes) - } - -and copy_constructor_arguments : - From.Parsetree.constructor_arguments -> - To.Parsetree.constructor_arguments - = - function - | From.Parsetree.Pcstr_tuple x0 -> - To.Parsetree.Pcstr_tuple - (List.map copy_core_type x0) - | From.Parsetree.Pcstr_record x0 -> - To.Parsetree.Pcstr_record - (List.map copy_label_declaration x0) - -and copy_label_declaration : - From.Parsetree.label_declaration -> To.Parsetree.label_declaration - = - fun - { From.Parsetree.pld_name = pld_name; - From.Parsetree.pld_mutable = pld_mutable; - From.Parsetree.pld_type = pld_type; - From.Parsetree.pld_loc = pld_loc; - From.Parsetree.pld_attributes = pld_attributes } - -> - { - To.Parsetree.pld_name = - (copy_loc (fun x -> x) pld_name); - To.Parsetree.pld_mutable = - (copy_mutable_flag pld_mutable); - To.Parsetree.pld_type = - (copy_core_type pld_type); - To.Parsetree.pld_loc = (copy_location pld_loc); - To.Parsetree.pld_attributes = - (copy_attributes pld_attributes) - } - -and copy_mutable_flag : - From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = - function - | From.Asttypes.Immutable -> To.Asttypes.Immutable - | From.Asttypes.Mutable -> To.Asttypes.Mutable - -and copy_variance : - From.Asttypes.variance -> To.Asttypes.variance = - function - | From.Asttypes.Covariant -> To.Asttypes.Covariant - | From.Asttypes.Contravariant -> To.Asttypes.Contravariant - | From.Asttypes.Invariant -> To.Asttypes.Invariant - -and copy_value_description : - From.Parsetree.value_description -> To.Parsetree.value_description - = - fun - { From.Parsetree.pval_name = pval_name; - From.Parsetree.pval_type = pval_type; - From.Parsetree.pval_prim = pval_prim; - From.Parsetree.pval_attributes = pval_attributes; - From.Parsetree.pval_loc = pval_loc } - -> - { - To.Parsetree.pval_name = - (copy_loc (fun x -> x) pval_name); - To.Parsetree.pval_type = - (copy_core_type pval_type); - To.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - To.Parsetree.pval_attributes = - (copy_attributes pval_attributes); - To.Parsetree.pval_loc = (copy_location pval_loc) - } - -and copy_arg_label : - From.Asttypes.arg_label -> To.Asttypes.arg_label = - function - | From.Asttypes.Nolabel -> To.Asttypes.Nolabel - | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 - | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 - -and copy_closed_flag : - From.Asttypes.closed_flag -> To.Asttypes.closed_flag = - function - | From.Asttypes.Closed -> To.Asttypes.Closed - | From.Asttypes.Open -> To.Asttypes.Open - -and copy_label : - From.Asttypes.label -> To.Asttypes.label = fun x -> x - -and copy_rec_flag : - From.Asttypes.rec_flag -> To.Asttypes.rec_flag = - function - | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive - | From.Asttypes.Recursive -> To.Asttypes.Recursive - -and copy_constant : - From.Parsetree.constant -> To.Parsetree.constant = - function - | From.Parsetree.Pconst_integer (x0,x1) -> - To.Parsetree.Pconst_integer (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 - | From.Parsetree.Pconst_string (x0,x1) -> - To.Parsetree.Pconst_string (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_float (x0,x1) -> - To.Parsetree.Pconst_float (x0, (copy_option (fun x -> x) x1)) - -and copy_option : 'f0 'g0 . ('f0 -> 'g0) -> 'f0 option -> 'g0 option = - fun f0 -> function | None -> None | Some x0 -> Some (f0 x0) - -and copy_longident : From.Longident.t -> To.Longident.t = - function - | From.Longident.Lident x0 -> To.Longident.Lident x0 - | From.Longident.Ldot (x0,x1) -> - To.Longident.Ldot ((copy_longident x0), x1) - | From.Longident.Lapply (x0,x1) -> - To.Longident.Lapply - ((copy_longident x0), (copy_longident x1)) - -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc - = - fun f0 -> - fun { From.Asttypes.txt = txt; From.Asttypes.loc = loc } -> - { - To.Asttypes.txt = (f0 txt); - To.Asttypes.loc = (copy_location loc) - } - -and copy_location : From.Location.t -> To.Location.t = - fun - { From.Location.loc_start = loc_start; - From.Location.loc_end = loc_end; - From.Location.loc_ghost = loc_ghost } - -> - { - To.Location.loc_start = (copy_Lexing_position loc_start); - To.Location.loc_end = (copy_Lexing_position loc_end); - To.Location.loc_ghost = (copy_bool loc_ghost) - } - -and copy_bool : bool -> bool = function | false -> false | true -> true - -and copy_Lexing_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum + (fun x -> + let (x0, x1, x2) = x in + (x0, (List.map copy_out_type x1), + (Option.map copy_out_type x2))) otyext_constructors); + Ast_406.Outcometree.otyext_private = (copy_private_flag otyext_private) } - -let rec copy_out_phrase : - From.Outcometree.out_phrase -> To.Outcometree.out_phrase = +and copy_out_phrase : + Ast_407.Outcometree.out_phrase -> Ast_406.Outcometree.out_phrase = function - | From.Outcometree.Ophr_eval (x0,x1) -> - To.Outcometree.Ophr_eval - ((copy_out_value x0), - (copy_out_type x1)) - | From.Outcometree.Ophr_signature x0 -> - To.Outcometree.Ophr_signature + | Ast_407.Outcometree.Ophr_eval (x0, x1) -> + Ast_406.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1)) + | Ast_407.Outcometree.Ophr_signature x0 -> + Ast_406.Outcometree.Ophr_signature (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_sig_item x0), - (copy_option copy_out_value x1))) x0) - | From.Outcometree.Ophr_exception x0 -> - To.Outcometree.Ophr_exception - (let (x0,x1) = x0 in - ((copy_exn x0), (copy_out_value x1))) - -and copy_exn : exn -> exn = fun x -> x - + (fun x -> + let (x0, x1) = x in + ((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0) + | Ast_407.Outcometree.Ophr_exception x0 -> + Ast_406.Outcometree.Ophr_exception + (let (x0, x1) = x0 in (x0, (copy_out_value x1))) and copy_out_sig_item : - From.Outcometree.out_sig_item -> To.Outcometree.out_sig_item = + Ast_407.Outcometree.out_sig_item -> Ast_406.Outcometree.out_sig_item = function - | From.Outcometree.Osig_class (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class - ((copy_bool x0), x1, + | Ast_407.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> + Ast_406.Outcometree.Osig_class + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_class_type (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class_type - ((copy_bool x0), x1, + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_407.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> + Ast_406.Outcometree.Osig_class_type + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_typext (x0,x1) -> - To.Outcometree.Osig_typext - ((copy_out_extension_constructor x0), - (copy_out_ext_status x1)) - | From.Outcometree.Osig_modtype (x0,x1) -> - To.Outcometree.Osig_modtype - (x0, (copy_out_module_type x1)) - | From.Outcometree.Osig_module (x0,x1,x2) -> - To.Outcometree.Osig_module - (x0, (copy_out_module_type x1), - (copy_out_rec_status x2)) - | From.Outcometree.Osig_type (x0,x1) -> - To.Outcometree.Osig_type - ((copy_out_type_decl x0), - (copy_out_rec_status x1)) - | From.Outcometree.Osig_value x0 -> - To.Outcometree.Osig_value - (copy_out_val_decl x0) - | From.Outcometree.Osig_ellipsis -> To.Outcometree.Osig_ellipsis - + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_407.Outcometree.Osig_typext (x0, x1) -> + Ast_406.Outcometree.Osig_typext + ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) + | Ast_407.Outcometree.Osig_modtype (x0, x1) -> + Ast_406.Outcometree.Osig_modtype (x0, (copy_out_module_type x1)) + | Ast_407.Outcometree.Osig_module (x0, x1, x2) -> + Ast_406.Outcometree.Osig_module + (x0, (copy_out_module_type x1), (copy_out_rec_status x2)) + | Ast_407.Outcometree.Osig_type (x0, x1) -> + Ast_406.Outcometree.Osig_type + ((copy_out_type_decl x0), (copy_out_rec_status x1)) + | Ast_407.Outcometree.Osig_value x0 -> + Ast_406.Outcometree.Osig_value (copy_out_val_decl x0) + | Ast_407.Outcometree.Osig_ellipsis -> Ast_406.Outcometree.Osig_ellipsis and copy_out_val_decl : - From.Outcometree.out_val_decl -> To.Outcometree.out_val_decl = + Ast_407.Outcometree.out_val_decl -> Ast_406.Outcometree.out_val_decl = fun - { From.Outcometree.oval_name = oval_name; - From.Outcometree.oval_type = oval_type; - From.Outcometree.oval_prims = oval_prims; - From.Outcometree.oval_attributes = oval_attributes } - -> + { Ast_407.Outcometree.oval_name = oval_name; + Ast_407.Outcometree.oval_type = oval_type; + Ast_407.Outcometree.oval_prims = oval_prims; + Ast_407.Outcometree.oval_attributes = oval_attributes } + -> { - To.Outcometree.oval_name = oval_name; - To.Outcometree.oval_type = - (copy_out_type oval_type); - To.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); - To.Outcometree.oval_attributes = + Ast_406.Outcometree.oval_name = oval_name; + Ast_406.Outcometree.oval_type = (copy_out_type oval_type); + Ast_406.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); + Ast_406.Outcometree.oval_attributes = (List.map copy_out_attribute oval_attributes) } - and copy_out_type_decl : - From.Outcometree.out_type_decl -> To.Outcometree.out_type_decl = + Ast_407.Outcometree.out_type_decl -> Ast_406.Outcometree.out_type_decl = fun - { From.Outcometree.otype_name = otype_name; - From.Outcometree.otype_params = otype_params; - From.Outcometree.otype_type = otype_type; - From.Outcometree.otype_private = otype_private; - From.Outcometree.otype_immediate = otype_immediate; - From.Outcometree.otype_unboxed = otype_unboxed; - From.Outcometree.otype_cstrs = otype_cstrs } - -> + { Ast_407.Outcometree.otype_name = otype_name; + Ast_407.Outcometree.otype_params = otype_params; + Ast_407.Outcometree.otype_type = otype_type; + Ast_407.Outcometree.otype_private = otype_private; + Ast_407.Outcometree.otype_immediate = otype_immediate; + Ast_407.Outcometree.otype_unboxed = otype_unboxed; + Ast_407.Outcometree.otype_cstrs = otype_cstrs } + -> { - To.Outcometree.otype_name = otype_name; - To.Outcometree.otype_params = + Ast_406.Outcometree.otype_name = otype_name; + Ast_406.Outcometree.otype_params = (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) otype_params); - To.Outcometree.otype_type = - (copy_out_type otype_type); - To.Outcometree.otype_private = - (copy_From_Asttypes_private_flag otype_private); - To.Outcometree.otype_immediate = (copy_bool otype_immediate); - To.Outcometree.otype_unboxed = (copy_bool otype_unboxed); - To.Outcometree.otype_cstrs = + Ast_406.Outcometree.otype_type = (copy_out_type otype_type); + Ast_406.Outcometree.otype_private = (copy_private_flag otype_private); + Ast_406.Outcometree.otype_immediate = otype_immediate; + Ast_406.Outcometree.otype_unboxed = otype_unboxed; + Ast_406.Outcometree.otype_cstrs = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_type x0), - (copy_out_type x1))) otype_cstrs) + (fun x -> + let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1))) + otype_cstrs) } - and copy_out_module_type : - From.Outcometree.out_module_type -> To.Outcometree.out_module_type + Ast_407.Outcometree.out_module_type -> Ast_406.Outcometree.out_module_type = function - | From.Outcometree.Omty_abstract -> To.Outcometree.Omty_abstract - | From.Outcometree.Omty_functor (x0,x1,x2) -> - To.Outcometree.Omty_functor - (x0, (copy_option copy_out_module_type x1), - (copy_out_module_type x2)) - | From.Outcometree.Omty_ident x0 -> - To.Outcometree.Omty_ident (copy_out_ident x0) - | From.Outcometree.Omty_signature x0 -> - To.Outcometree.Omty_signature - (List.map copy_out_sig_item x0) - | From.Outcometree.Omty_alias x0 -> - To.Outcometree.Omty_alias (copy_out_ident x0) - + | Ast_407.Outcometree.Omty_abstract -> Ast_406.Outcometree.Omty_abstract + | Ast_407.Outcometree.Omty_functor (x0, x1, x2) -> + Ast_406.Outcometree.Omty_functor + (x0, (Option.map copy_out_module_type x1), (copy_out_module_type x2)) + | Ast_407.Outcometree.Omty_ident x0 -> + Ast_406.Outcometree.Omty_ident (copy_out_ident x0) + | Ast_407.Outcometree.Omty_signature x0 -> + Ast_406.Outcometree.Omty_signature (List.map copy_out_sig_item x0) + | Ast_407.Outcometree.Omty_alias x0 -> + Ast_406.Outcometree.Omty_alias (copy_out_ident x0) and copy_out_ext_status : - From.Outcometree.out_ext_status -> To.Outcometree.out_ext_status = + Ast_407.Outcometree.out_ext_status -> Ast_406.Outcometree.out_ext_status = function - | From.Outcometree.Oext_first -> To.Outcometree.Oext_first - | From.Outcometree.Oext_next -> To.Outcometree.Oext_next - | From.Outcometree.Oext_exception -> To.Outcometree.Oext_exception - + | Ast_407.Outcometree.Oext_first -> Ast_406.Outcometree.Oext_first + | Ast_407.Outcometree.Oext_next -> Ast_406.Outcometree.Oext_next + | Ast_407.Outcometree.Oext_exception -> Ast_406.Outcometree.Oext_exception and copy_out_extension_constructor : - From.Outcometree.out_extension_constructor -> - To.Outcometree.out_extension_constructor + Ast_407.Outcometree.out_extension_constructor -> + Ast_406.Outcometree.out_extension_constructor = fun - { From.Outcometree.oext_name = oext_name; - From.Outcometree.oext_type_name = oext_type_name; - From.Outcometree.oext_type_params = oext_type_params; - From.Outcometree.oext_args = oext_args; - From.Outcometree.oext_ret_type = oext_ret_type; - From.Outcometree.oext_private = oext_private } - -> + { Ast_407.Outcometree.oext_name = oext_name; + Ast_407.Outcometree.oext_type_name = oext_type_name; + Ast_407.Outcometree.oext_type_params = oext_type_params; + Ast_407.Outcometree.oext_args = oext_args; + Ast_407.Outcometree.oext_ret_type = oext_ret_type; + Ast_407.Outcometree.oext_private = oext_private } + -> { - To.Outcometree.oext_name = oext_name; - To.Outcometree.oext_type_name = oext_type_name; - To.Outcometree.oext_type_params = - (List.map (fun x -> x) oext_type_params); - To.Outcometree.oext_args = - (List.map copy_out_type oext_args); - To.Outcometree.oext_ret_type = - (copy_option copy_out_type oext_ret_type); - To.Outcometree.oext_private = - (copy_From_Asttypes_private_flag oext_private) + Ast_406.Outcometree.oext_name = oext_name; + Ast_406.Outcometree.oext_type_name = oext_type_name; + Ast_406.Outcometree.oext_type_params = + (List.map (fun x -> x) oext_type_params); + Ast_406.Outcometree.oext_args = (List.map copy_out_type oext_args); + Ast_406.Outcometree.oext_ret_type = + (Option.map copy_out_type oext_ret_type); + Ast_406.Outcometree.oext_private = (copy_private_flag oext_private) } - -and copy_From_Asttypes_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = +and copy_private_flag : + Ast_407.Asttypes.private_flag -> Ast_406.Asttypes.private_flag = function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - + | Ast_407.Asttypes.Private -> Ast_406.Asttypes.Private + | Ast_407.Asttypes.Public -> Ast_406.Asttypes.Public and copy_out_rec_status : - From.Outcometree.out_rec_status -> To.Outcometree.out_rec_status = + Ast_407.Outcometree.out_rec_status -> Ast_406.Outcometree.out_rec_status = function - | From.Outcometree.Orec_not -> To.Outcometree.Orec_not - | From.Outcometree.Orec_first -> To.Outcometree.Orec_first - | From.Outcometree.Orec_next -> To.Outcometree.Orec_next - + | Ast_407.Outcometree.Orec_not -> Ast_406.Outcometree.Orec_not + | Ast_407.Outcometree.Orec_first -> Ast_406.Outcometree.Orec_first + | Ast_407.Outcometree.Orec_next -> Ast_406.Outcometree.Orec_next and copy_out_class_type : - From.Outcometree.out_class_type -> To.Outcometree.out_class_type = - function - | From.Outcometree.Octy_constr (x0,x1) -> - To.Outcometree.Octy_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Octy_arrow (x0,x1,x2) -> - To.Outcometree.Octy_arrow - (x0, (copy_out_type x1), - (copy_out_class_type x2)) - | From.Outcometree.Octy_signature (x0,x1) -> - To.Outcometree.Octy_signature - ((copy_option copy_out_type x0), + Ast_407.Outcometree.out_class_type -> Ast_406.Outcometree.out_class_type = + function + | Ast_407.Outcometree.Octy_constr (x0, x1) -> + Ast_406.Outcometree.Octy_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_407.Outcometree.Octy_arrow (x0, x1, x2) -> + Ast_406.Outcometree.Octy_arrow + (x0, (copy_out_type x1), (copy_out_class_type x2)) + | Ast_407.Outcometree.Octy_signature (x0, x1) -> + Ast_406.Outcometree.Octy_signature + ((Option.map copy_out_type x0), (List.map copy_out_class_sig_item x1)) - and copy_out_class_sig_item : - From.Outcometree.out_class_sig_item -> - To.Outcometree.out_class_sig_item + Ast_407.Outcometree.out_class_sig_item -> + Ast_406.Outcometree.out_class_sig_item = function - | From.Outcometree.Ocsg_constraint (x0,x1) -> - To.Outcometree.Ocsg_constraint - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Ocsg_method (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_method - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - | From.Outcometree.Ocsg_value (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_value - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - + | Ast_407.Outcometree.Ocsg_constraint (x0, x1) -> + Ast_406.Outcometree.Ocsg_constraint + ((copy_out_type x0), (copy_out_type x1)) + | Ast_407.Outcometree.Ocsg_method (x0, x1, x2, x3) -> + Ast_406.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3)) + | Ast_407.Outcometree.Ocsg_value (x0, x1, x2, x3) -> + Ast_406.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3)) and copy_out_type : - From.Outcometree.out_type -> To.Outcometree.out_type = - function - | From.Outcometree.Otyp_abstract -> To.Outcometree.Otyp_abstract - | From.Outcometree.Otyp_open -> To.Outcometree.Otyp_open - | From.Outcometree.Otyp_alias (x0,x1) -> - To.Outcometree.Otyp_alias - ((copy_out_type x0), x1) - | From.Outcometree.Otyp_arrow (x0,x1,x2) -> - To.Outcometree.Otyp_arrow - (x0, (copy_out_type x1), - (copy_out_type x2)) - | From.Outcometree.Otyp_class (x0,x1,x2) -> - To.Outcometree.Otyp_class - ((copy_bool x0), (copy_out_ident x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_constr (x0,x1) -> - To.Outcometree.Otyp_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Otyp_manifest (x0,x1) -> - To.Outcometree.Otyp_manifest - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Otyp_object (x0,x1) -> - To.Outcometree.Otyp_object - ((List.map - (fun x -> - let (x0,x1) = x in - (x0, (copy_out_type x1))) x0), - (copy_option copy_bool x1)) - | From.Outcometree.Otyp_record x0 -> - To.Outcometree.Otyp_record + Ast_407.Outcometree.out_type -> Ast_406.Outcometree.out_type = + function + | Ast_407.Outcometree.Otyp_abstract -> Ast_406.Outcometree.Otyp_abstract + | Ast_407.Outcometree.Otyp_open -> Ast_406.Outcometree.Otyp_open + | Ast_407.Outcometree.Otyp_alias (x0, x1) -> + Ast_406.Outcometree.Otyp_alias ((copy_out_type x0), x1) + | Ast_407.Outcometree.Otyp_arrow (x0, x1, x2) -> + Ast_406.Outcometree.Otyp_arrow + (x0, (copy_out_type x1), (copy_out_type x2)) + | Ast_407.Outcometree.Otyp_class (x0, x1, x2) -> + Ast_406.Outcometree.Otyp_class + (x0, (copy_out_ident x1), (List.map copy_out_type x2)) + | Ast_407.Outcometree.Otyp_constr (x0, x1) -> + Ast_406.Outcometree.Otyp_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_407.Outcometree.Otyp_manifest (x0, x1) -> + Ast_406.Outcometree.Otyp_manifest + ((copy_out_type x0), (copy_out_type x1)) + | Ast_407.Outcometree.Otyp_object (x0, x1) -> + Ast_406.Outcometree.Otyp_object + ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0), + (Option.map (fun x -> x) x1)) + | Ast_407.Outcometree.Otyp_record x0 -> + Ast_406.Outcometree.Otyp_record (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), (copy_out_type x2))) - x0) - | From.Outcometree.Otyp_stuff x0 -> To.Outcometree.Otyp_stuff x0 - | From.Outcometree.Otyp_sum x0 -> - To.Outcometree.Otyp_sum + (fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0) + | Ast_407.Outcometree.Otyp_stuff x0 -> Ast_406.Outcometree.Otyp_stuff x0 + | Ast_407.Outcometree.Otyp_sum x0 -> + Ast_406.Outcometree.Otyp_sum (List.map - (fun x -> - let (x0,x1,x2) = x in + (fun x -> + let (x0, x1, x2) = x in (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) x0) - | From.Outcometree.Otyp_tuple x0 -> - To.Outcometree.Otyp_tuple - (List.map copy_out_type x0) - | From.Outcometree.Otyp_var (x0,x1) -> - To.Outcometree.Otyp_var ((copy_bool x0), x1) - | From.Outcometree.Otyp_variant (x0,x1,x2,x3) -> - To.Outcometree.Otyp_variant - ((copy_bool x0), (copy_out_variant x1), - (copy_bool x2), - (copy_option (fun x -> List.map (fun x -> x) x) x3)) - | From.Outcometree.Otyp_poly (x0,x1) -> - To.Outcometree.Otyp_poly - ((List.map (fun x -> x) x0), (copy_out_type x1)) - | From.Outcometree.Otyp_module (x0,x1,x2) -> - To.Outcometree.Otyp_module - (x0, (List.map (fun x -> x) x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_attribute (x0,x1) -> - To.Outcometree.Otyp_attribute - ((copy_out_type x0), - (copy_out_attribute x1)) - -and copy_out_string : - From.Outcometree.out_string -> To.Outcometree.out_string = - function - | From.Outcometree.Ostr_string -> To.Outcometree.Ostr_string - | From.Outcometree.Ostr_bytes -> To.Outcometree.Ostr_bytes - + (Option.map copy_out_type x2))) x0) + | Ast_407.Outcometree.Otyp_tuple x0 -> + Ast_406.Outcometree.Otyp_tuple (List.map copy_out_type x0) + | Ast_407.Outcometree.Otyp_var (x0, x1) -> + Ast_406.Outcometree.Otyp_var (x0, x1) + | Ast_407.Outcometree.Otyp_variant (x0, x1, x2, x3) -> + Ast_406.Outcometree.Otyp_variant + (x0, (copy_out_variant x1), x2, + (Option.map (fun x -> List.map (fun x -> x) x) x3)) + | Ast_407.Outcometree.Otyp_poly (x0, x1) -> + Ast_406.Outcometree.Otyp_poly + ((List.map (fun x -> x) x0), (copy_out_type x1)) + | Ast_407.Outcometree.Otyp_module (x0, x1, x2) -> + Ast_406.Outcometree.Otyp_module + (x0, (List.map (fun x -> x) x1), (List.map copy_out_type x2)) + | Ast_407.Outcometree.Otyp_attribute (x0, x1) -> + Ast_406.Outcometree.Otyp_attribute + ((copy_out_type x0), (copy_out_attribute x1)) and copy_out_attribute : - From.Outcometree.out_attribute -> To.Outcometree.out_attribute = - fun { From.Outcometree.oattr_name = oattr_name } -> - { To.Outcometree.oattr_name = oattr_name } - + Ast_407.Outcometree.out_attribute -> Ast_406.Outcometree.out_attribute = + fun { Ast_407.Outcometree.oattr_name = oattr_name } -> + { Ast_406.Outcometree.oattr_name = oattr_name } and copy_out_variant : - From.Outcometree.out_variant -> To.Outcometree.out_variant = + Ast_407.Outcometree.out_variant -> Ast_406.Outcometree.out_variant = function - | From.Outcometree.Ovar_fields x0 -> - To.Outcometree.Ovar_fields + | Ast_407.Outcometree.Ovar_fields x0 -> + Ast_406.Outcometree.Ovar_fields (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), - (List.map copy_out_type x2))) x0) - | From.Outcometree.Ovar_typ x0 -> - To.Outcometree.Ovar_typ (copy_out_type x0) - + (fun x -> + let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2))) + x0) + | Ast_407.Outcometree.Ovar_typ x0 -> + Ast_406.Outcometree.Ovar_typ (copy_out_type x0) and copy_out_value : - From.Outcometree.out_value -> To.Outcometree.out_value = - function - | From.Outcometree.Oval_array x0 -> - To.Outcometree.Oval_array - (List.map copy_out_value x0) - | From.Outcometree.Oval_char x0 -> To.Outcometree.Oval_char x0 - | From.Outcometree.Oval_constr (x0,x1) -> - To.Outcometree.Oval_constr - ((copy_out_ident x0), - (List.map copy_out_value x1)) - | From.Outcometree.Oval_ellipsis -> To.Outcometree.Oval_ellipsis - | From.Outcometree.Oval_float x0 -> - To.Outcometree.Oval_float (copy_float x0) - | From.Outcometree.Oval_int x0 -> To.Outcometree.Oval_int x0 - | From.Outcometree.Oval_int32 x0 -> To.Outcometree.Oval_int32 x0 - | From.Outcometree.Oval_int64 x0 -> To.Outcometree.Oval_int64 x0 - | From.Outcometree.Oval_nativeint x0 -> - To.Outcometree.Oval_nativeint x0 - | From.Outcometree.Oval_list x0 -> - To.Outcometree.Oval_list - (List.map copy_out_value x0) - | From.Outcometree.Oval_printer x0 -> - To.Outcometree.Oval_printer x0 - | From.Outcometree.Oval_record x0 -> - To.Outcometree.Oval_record + Ast_407.Outcometree.out_value -> Ast_406.Outcometree.out_value = + function + | Ast_407.Outcometree.Oval_array x0 -> + Ast_406.Outcometree.Oval_array (List.map copy_out_value x0) + | Ast_407.Outcometree.Oval_char x0 -> Ast_406.Outcometree.Oval_char x0 + | Ast_407.Outcometree.Oval_constr (x0, x1) -> + Ast_406.Outcometree.Oval_constr + ((copy_out_ident x0), (List.map copy_out_value x1)) + | Ast_407.Outcometree.Oval_ellipsis -> Ast_406.Outcometree.Oval_ellipsis + | Ast_407.Outcometree.Oval_float x0 -> Ast_406.Outcometree.Oval_float x0 + | Ast_407.Outcometree.Oval_int x0 -> Ast_406.Outcometree.Oval_int x0 + | Ast_407.Outcometree.Oval_int32 x0 -> Ast_406.Outcometree.Oval_int32 x0 + | Ast_407.Outcometree.Oval_int64 x0 -> Ast_406.Outcometree.Oval_int64 x0 + | Ast_407.Outcometree.Oval_nativeint x0 -> + Ast_406.Outcometree.Oval_nativeint x0 + | Ast_407.Outcometree.Oval_list x0 -> + Ast_406.Outcometree.Oval_list (List.map copy_out_value x0) + | Ast_407.Outcometree.Oval_printer x0 -> + Ast_406.Outcometree.Oval_printer x0 + | Ast_407.Outcometree.Oval_record x0 -> + Ast_406.Outcometree.Oval_record (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_ident x0), - (copy_out_value x1))) x0) - | From.Outcometree.Oval_string (x0, x1, x2) -> - To.Outcometree.Oval_string (x0, x1, copy_out_string x2) - | From.Outcometree.Oval_stuff x0 -> To.Outcometree.Oval_stuff x0 - | From.Outcometree.Oval_tuple x0 -> - To.Outcometree.Oval_tuple - (List.map copy_out_value x0) - | From.Outcometree.Oval_variant (x0,x1) -> - To.Outcometree.Oval_variant - (x0, (copy_option copy_out_value x1)) - -and copy_float : float -> float = fun x -> x - -and copy_out_ident : - From.Outcometree.out_ident -> To.Outcometree.out_ident = - function - | From.Outcometree.Oide_apply (x0,x1) -> - To.Outcometree.Oide_apply - ((copy_out_ident x0), - (copy_out_ident x1)) - | From.Outcometree.Oide_dot (x0,x1) -> - To.Outcometree.Oide_dot - ((copy_out_ident x0), x1) - | From.Outcometree.Oide_ident x0 -> To.Outcometree.Oide_ident x0 - -let rec copy_toplevel_phrase : - From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = - function - | From.Parsetree.Ptop_def x0 -> - To.Parsetree.Ptop_def (copy_structure x0) - | From.Parsetree.Ptop_dir (x0,x1) -> - To.Parsetree.Ptop_dir - (x0, (copy_directive_argument x1)) - -and copy_directive_argument : - From.Parsetree.directive_argument -> To.Parsetree.directive_argument = + (fun x -> + let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1))) + x0) + | Ast_407.Outcometree.Oval_string (x0, x1, x2) -> + Ast_406.Outcometree.Oval_string (x0, x1, (copy_out_string x2)) + | Ast_407.Outcometree.Oval_stuff x0 -> Ast_406.Outcometree.Oval_stuff x0 + | Ast_407.Outcometree.Oval_tuple x0 -> + Ast_406.Outcometree.Oval_tuple (List.map copy_out_value x0) + | Ast_407.Outcometree.Oval_variant (x0, x1) -> + Ast_406.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1)) +and copy_out_string : + Ast_407.Outcometree.out_string -> Ast_406.Outcometree.out_string = function - | From.Parsetree.Pdir_none -> To.Parsetree.Pdir_none - | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 - | From.Parsetree.Pdir_int (x0,x1) -> - To.Parsetree.Pdir_int (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pdir_ident x0 -> - To.Parsetree.Pdir_ident (copy_longident x0) - | From.Parsetree.Pdir_bool x0 -> - To.Parsetree.Pdir_bool (copy_bool x0) - -let copy_out_type_extension : - From.Outcometree.out_type_extension -> To.Outcometree.out_type_extension = - fun - { From.Outcometree.otyext_name = otyext_name; - From.Outcometree.otyext_params = otyext_params; - From.Outcometree.otyext_constructors = otyext_constructors; - From.Outcometree.otyext_private = otyext_private } - -> - { - To.Outcometree.otyext_name = otyext_name; - To.Outcometree.otyext_params = - (List.map (fun x -> x) otyext_params); - To.Outcometree.otyext_constructors = - (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) - otyext_constructors); - To.Outcometree.otyext_private = - (copy_private_flag otyext_private) - } - -let copy_cases x = List.map copy_case x -let copy_pat = copy_pattern -let copy_expr = copy_expression -let copy_typ = copy_core_type + | Ast_407.Outcometree.Ostr_string -> Ast_406.Outcometree.Ostr_string + | Ast_407.Outcometree.Ostr_bytes -> Ast_406.Outcometree.Ostr_bytes +and copy_out_ident : + Ast_407.Outcometree.out_ident -> Ast_406.Outcometree.out_ident = + function + | Ast_407.Outcometree.Oide_apply (x0, x1) -> + Ast_406.Outcometree.Oide_apply + ((copy_out_ident x0), (copy_out_ident x1)) + | Ast_407.Outcometree.Oide_dot (x0, x1) -> + Ast_406.Outcometree.Oide_dot ((copy_out_ident x0), x1) + | Ast_407.Outcometree.Oide_ident x0 -> Ast_406.Outcometree.Oide_ident x0 diff --git a/src/vendored-omp/src/migrate_parsetree_407_408.ml b/src/vendored-omp/src/migrate_parsetree_407_408.ml index f9af1f5cd..9c8514983 100644 --- a/src/vendored-omp/src/migrate_parsetree_407_408.ml +++ b/src/vendored-omp/src/migrate_parsetree_407_408.ml @@ -15,124 +15,3 @@ include Migrate_parsetree_407_408_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - (*$*) - } as mapper) -> - let module Def = Migrate_parsetree_def in - let migration_error location feature = - raise (Def.Migration_error (feature, location)) in - let module R = Migrate_parsetree_408_407_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - (*$*) - (* The following ones were introduced in 4.08. *) - binding_op = (fun _ x -> migration_error x.pbop_op.Location.loc Def.Pexp_letop); - module_substitution = (fun _ x -> migration_error x.pms_loc Def.Psig_modsubst); - open_declaration = (fun _ x -> migration_error x.popen_loc Def.Pexp_open); - type_exception = (fun _ x -> migration_error x.ptyexn_loc Def.Psig_typesubst); - } diff --git a/src/vendored-omp/src/migrate_parsetree_407_408_migrate.ml b/src/vendored-omp/src/migrate_parsetree_407_408_migrate.ml index a0429ec92..e26aa2292 100644 --- a/src/vendored-omp/src/migrate_parsetree_407_408_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_407_408_migrate.ml @@ -1,1808 +1,309 @@ +open Stdlib0 module From = Ast_407 module To = Ast_408 - -let rec copy_toplevel_phrase : - From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = - function - | From.Parsetree.Ptop_def x0 -> - To.Parsetree.Ptop_def (copy_structure x0) - | From.Parsetree.Ptop_dir (x0,x1) -> - To.Parsetree.Ptop_dir - { To.Parsetree.pdir_name = { To.Location.txt = x0; To.Location.loc = Location.none; }; - To.Parsetree.pdir_arg = copy_directive_argument x1; - To.Parsetree.pdir_loc = Location.none; } - -and copy_directive_argument : - From.Parsetree.directive_argument -> - To.Parsetree.directive_argument option - = - let wrap pdira_desc = - Some { To.Parsetree.pdira_desc; - To.Parsetree.pdira_loc = Location.none; } in - function - | From.Parsetree.Pdir_none -> None - | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 |> wrap - | From.Parsetree.Pdir_int (x0,x1) -> - To.Parsetree.Pdir_int (x0, (copy_option (fun x -> x) x1)) |> wrap - | From.Parsetree.Pdir_ident x0 -> - To.Parsetree.Pdir_ident (copy_longident x0) |> wrap - | From.Parsetree.Pdir_bool x0 -> - To.Parsetree.Pdir_bool (copy_bool x0) |> wrap - -and copy_expression : - From.Parsetree.expression -> To.Parsetree.expression = - fun - { From.Parsetree.pexp_desc = pexp_desc; - From.Parsetree.pexp_loc = pexp_loc; - From.Parsetree.pexp_attributes = pexp_attributes } - -> - { - To.Parsetree.pexp_desc = - (copy_expression_desc pexp_desc); - To.Parsetree.pexp_loc = (copy_location pexp_loc); - To.Parsetree.pexp_loc_stack = []; - To.Parsetree.pexp_attributes = - (copy_attributes pexp_attributes) - } - -and copy_expression_desc : - From.Parsetree.expression_desc -> To.Parsetree.expression_desc = - function - | From.Parsetree.Pexp_ident x0 -> - To.Parsetree.Pexp_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_constant x0 -> - To.Parsetree.Pexp_constant (copy_constant x0) - | From.Parsetree.Pexp_let (x0,x1,x2) -> - To.Parsetree.Pexp_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_expression x2)) - | From.Parsetree.Pexp_function x0 -> - To.Parsetree.Pexp_function - (List.map copy_case x0) - | From.Parsetree.Pexp_fun (x0,x1,x2,x3) -> - To.Parsetree.Pexp_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_expression x3)) - | From.Parsetree.Pexp_apply (x0,x1) -> - To.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pexp_match (x0,x1) -> - To.Parsetree.Pexp_match - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_try (x0,x1) -> - To.Parsetree.Pexp_try - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_tuple x0 -> - To.Parsetree.Pexp_tuple - (List.map copy_expression x0) - | From.Parsetree.Pexp_construct (x0,x1) -> - To.Parsetree.Pexp_construct - ((copy_loc copy_longident x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_variant (x0,x1) -> - To.Parsetree.Pexp_variant - ((copy_label x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_record (x0,x1) -> - To.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_expression x1))) x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_field (x0,x1) -> - To.Parsetree.Pexp_field - ((copy_expression x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pexp_setfield (x0,x1,x2) -> - To.Parsetree.Pexp_setfield - ((copy_expression x0), - (copy_loc copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_array x0 -> - To.Parsetree.Pexp_array - (List.map copy_expression x0) - | From.Parsetree.Pexp_ifthenelse (x0,x1,x2) -> - To.Parsetree.Pexp_ifthenelse - ((copy_expression x0), - (copy_expression x1), - (copy_option copy_expression x2)) - | From.Parsetree.Pexp_sequence (x0,x1) -> - To.Parsetree.Pexp_sequence - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_while (x0,x1) -> - To.Parsetree.Pexp_while - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_for (x0,x1,x2,x3,x4) -> - To.Parsetree.Pexp_for - ((copy_pattern x0), - (copy_expression x1), - (copy_expression x2), - (copy_direction_flag x3), - (copy_expression x4)) - | From.Parsetree.Pexp_constraint (x0,x1) -> - To.Parsetree.Pexp_constraint - ((copy_expression x0), - (copy_core_type x1)) - | From.Parsetree.Pexp_coerce (x0,x1,x2) -> - To.Parsetree.Pexp_coerce - ((copy_expression x0), - (copy_option copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Pexp_send (x0,x1) -> - To.Parsetree.Pexp_send - ((copy_expression x0), - (copy_loc copy_label x1)) - | From.Parsetree.Pexp_new x0 -> - To.Parsetree.Pexp_new - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_setinstvar (x0,x1) -> - To.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), - (copy_expression x1)) - | From.Parsetree.Pexp_override x0 -> - To.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_label x0), - (copy_expression x1))) x0) - | From.Parsetree.Pexp_letmodule (x0,x1,x2) -> - To.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> x) x0), - (copy_module_expr x1), - (copy_expression x2)) - | From.Parsetree.Pexp_letexception (x0,x1) -> - To.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), - (copy_expression x1)) - | From.Parsetree.Pexp_assert x0 -> - To.Parsetree.Pexp_assert (copy_expression x0) - | From.Parsetree.Pexp_lazy x0 -> - To.Parsetree.Pexp_lazy (copy_expression x0) - | From.Parsetree.Pexp_poly (x0,x1) -> - To.Parsetree.Pexp_poly - ((copy_expression x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pexp_object x0 -> - To.Parsetree.Pexp_object - (copy_class_structure x0) - | From.Parsetree.Pexp_newtype (x0,x1) -> - To.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), - (copy_expression x1)) - | From.Parsetree.Pexp_pack x0 -> - To.Parsetree.Pexp_pack (copy_module_expr x0) - | From.Parsetree.Pexp_open (x0,x1,x2) -> - To.Parsetree.Pexp_open - ({ To.Parsetree.popen_expr = - { To.Parsetree.pmod_desc = To.Parsetree.Pmod_ident (copy_loc copy_longident x1); - To.Parsetree.pmod_loc = x1.Location.loc; - To.Parsetree.pmod_attributes = []; }; - To.Parsetree.popen_override = (copy_override_flag x0); - To.Parsetree.popen_loc = x1.Location.loc; - To.Parsetree.popen_attributes = []; }, - (copy_expression x2)) - | From.Parsetree.Pexp_extension x0 -> - To.Parsetree.Pexp_extension (copy_extension x0) - | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable - -and copy_direction_flag : - From.Asttypes.direction_flag -> To.Asttypes.direction_flag = - function - | From.Asttypes.Upto -> To.Asttypes.Upto - | From.Asttypes.Downto -> To.Asttypes.Downto - -and copy_case : - From.Parsetree.case -> To.Parsetree.case = - fun - { From.Parsetree.pc_lhs = pc_lhs; - From.Parsetree.pc_guard = pc_guard; - From.Parsetree.pc_rhs = pc_rhs } - -> - { - To.Parsetree.pc_lhs = (copy_pattern pc_lhs); - To.Parsetree.pc_guard = - (copy_option copy_expression pc_guard); - To.Parsetree.pc_rhs = (copy_expression pc_rhs) - } - -and copy_value_binding : - From.Parsetree.value_binding -> To.Parsetree.value_binding = - fun - { From.Parsetree.pvb_pat = pvb_pat; - From.Parsetree.pvb_expr = pvb_expr; - From.Parsetree.pvb_attributes = pvb_attributes; - From.Parsetree.pvb_loc = pvb_loc } - -> - { - To.Parsetree.pvb_pat = (copy_pattern pvb_pat); - To.Parsetree.pvb_expr = - (copy_expression pvb_expr); - To.Parsetree.pvb_attributes = - (copy_attributes pvb_attributes); - To.Parsetree.pvb_loc = (copy_location pvb_loc) - } - -and copy_pattern : - From.Parsetree.pattern -> To.Parsetree.pattern = - fun - { From.Parsetree.ppat_desc = ppat_desc; - From.Parsetree.ppat_loc = ppat_loc; - From.Parsetree.ppat_attributes = ppat_attributes } - -> - { - To.Parsetree.ppat_desc = - (copy_pattern_desc ppat_desc); - To.Parsetree.ppat_loc = (copy_location ppat_loc); - To.Parsetree.ppat_loc_stack = []; - To.Parsetree.ppat_attributes = - (copy_attributes ppat_attributes) - } - -and copy_pattern_desc : - From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc = - function - | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any - | From.Parsetree.Ppat_var x0 -> - To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_alias (x0,x1) -> - To.Parsetree.Ppat_alias - ((copy_pattern x0), - (copy_loc (fun x -> x) x1)) - | From.Parsetree.Ppat_constant x0 -> - To.Parsetree.Ppat_constant (copy_constant x0) - | From.Parsetree.Ppat_interval (x0,x1) -> - To.Parsetree.Ppat_interval - ((copy_constant x0), - (copy_constant x1)) - | From.Parsetree.Ppat_tuple x0 -> - To.Parsetree.Ppat_tuple - (List.map copy_pattern x0) - | From.Parsetree.Ppat_construct (x0,x1) -> - To.Parsetree.Ppat_construct - ((copy_loc copy_longident x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_variant (x0,x1) -> - To.Parsetree.Ppat_variant - ((copy_label x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_record (x0,x1) -> - To.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ppat_array x0 -> - To.Parsetree.Ppat_array - (List.map copy_pattern x0) - | From.Parsetree.Ppat_or (x0,x1) -> - To.Parsetree.Ppat_or - ((copy_pattern x0), - (copy_pattern x1)) - | From.Parsetree.Ppat_constraint (x0,x1) -> - To.Parsetree.Ppat_constraint - ((copy_pattern x0), - (copy_core_type x1)) - | From.Parsetree.Ppat_type x0 -> - To.Parsetree.Ppat_type - (copy_loc copy_longident x0) - | From.Parsetree.Ppat_lazy x0 -> - To.Parsetree.Ppat_lazy (copy_pattern x0) - | From.Parsetree.Ppat_unpack x0 -> - To.Parsetree.Ppat_unpack - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_exception x0 -> - To.Parsetree.Ppat_exception (copy_pattern x0) - | From.Parsetree.Ppat_extension x0 -> - To.Parsetree.Ppat_extension (copy_extension x0) - | From.Parsetree.Ppat_open (x0,x1) -> - To.Parsetree.Ppat_open - ((copy_loc copy_longident x0), - (copy_pattern x1)) - -and copy_core_type : - From.Parsetree.core_type -> To.Parsetree.core_type = - fun - { From.Parsetree.ptyp_desc = ptyp_desc; - From.Parsetree.ptyp_loc = ptyp_loc; - From.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - To.Parsetree.ptyp_desc = - (copy_core_type_desc ptyp_desc); - To.Parsetree.ptyp_loc = (copy_location ptyp_loc); - To.Parsetree.ptyp_loc_stack = []; - To.Parsetree.ptyp_attributes = - (copy_attributes ptyp_attributes) - } - -and copy_core_type_desc : - From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = - function - | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any - | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 - | From.Parsetree.Ptyp_arrow (x0,x1,x2) -> - To.Parsetree.Ptyp_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Ptyp_tuple x0 -> - To.Parsetree.Ptyp_tuple - (List.map copy_core_type x0) - | From.Parsetree.Ptyp_constr (x0,x1) -> - To.Parsetree.Ptyp_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_object (x0,x1) -> - To.Parsetree.Ptyp_object - ((List.map copy_object_field x0), - (copy_closed_flag x1)) - | From.Parsetree.Ptyp_class (x0,x1) -> - To.Parsetree.Ptyp_class - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_alias (x0,x1) -> - To.Parsetree.Ptyp_alias - ((copy_core_type x0), x1) - | From.Parsetree.Ptyp_variant (x0,x1,x2) -> - To.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), - (copy_closed_flag x1), - (copy_option (fun x -> List.map copy_label x) x2)) - | From.Parsetree.Ptyp_poly (x0,x1) -> - To.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | From.Parsetree.Ptyp_package x0 -> - To.Parsetree.Ptyp_package (copy_package_type x0) - | From.Parsetree.Ptyp_extension x0 -> - To.Parsetree.Ptyp_extension (copy_extension x0) - -and copy_package_type : - From.Parsetree.package_type -> To.Parsetree.package_type = - fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_core_type x1))) x1)) - -and copy_row_field : - From.Parsetree.row_field -> To.Parsetree.row_field = - function - | From.Parsetree.Rtag (x0,x1,x2,x3) -> - { To.Parsetree.prf_desc = - (To.Parsetree.Rtag - ((copy_loc copy_label x0), - (copy_bool x2), - (List.map copy_core_type x3))); - To.Parsetree.prf_loc = x0.Location.loc; - To.Parsetree.prf_attributes = (copy_attributes x1); } - | From.Parsetree.Rinherit x0 -> - { To.Parsetree.prf_desc = (To.Parsetree.Rinherit (copy_core_type x0)); - To.Parsetree.prf_loc = x0.From.Parsetree.ptyp_loc; - To.Parsetree.prf_attributes = []; } - -and copy_object_field : - From.Parsetree.object_field -> To.Parsetree.object_field = - function - | From.Parsetree.Otag (x0,x1,x2) -> - { To.Parsetree.pof_desc = - (To.Parsetree.Otag - ((copy_loc copy_label x0), - (copy_core_type x2))); - To.Parsetree.pof_loc = x0.Location.loc; - To.Parsetree.pof_attributes = (copy_attributes x1); } - | From.Parsetree.Oinherit x0 -> - { To.Parsetree.pof_desc = (To.Parsetree.Oinherit (copy_core_type x0)); - To.Parsetree.pof_loc = x0.From.Parsetree.ptyp_loc; - To.Parsetree.pof_attributes = []; } - -and copy_attributes : - From.Parsetree.attributes -> To.Parsetree.attributes = - fun x -> List.map copy_attribute x - -and copy_attribute : - From.Parsetree.attribute -> To.Parsetree.attribute = - fun x -> - let (x0,x1) = x in - { To.Parsetree.attr_name = copy_loc (fun x -> x) x0; - To.Parsetree.attr_payload = copy_payload x1; - To.Parsetree.attr_loc = x0.Location.loc; } - -and copy_payload : - From.Parsetree.payload -> To.Parsetree.payload = - function - | From.Parsetree.PStr x0 -> - To.Parsetree.PStr (copy_structure x0) - | From.Parsetree.PSig x0 -> - To.Parsetree.PSig (copy_signature x0) - | From.Parsetree.PTyp x0 -> - To.Parsetree.PTyp (copy_core_type x0) - | From.Parsetree.PPat (x0,x1) -> - To.Parsetree.PPat - ((copy_pattern x0), - (copy_option copy_expression x1)) - -and copy_structure : - From.Parsetree.structure -> To.Parsetree.structure = - fun x -> List.map copy_structure_item x - -and copy_structure_item : - From.Parsetree.structure_item -> To.Parsetree.structure_item = - fun - { From.Parsetree.pstr_desc = pstr_desc; - From.Parsetree.pstr_loc = pstr_loc } - -> - { - To.Parsetree.pstr_desc = - (copy_structure_item_desc pstr_desc); - To.Parsetree.pstr_loc = (copy_location pstr_loc) - } - -and copy_structure_item_desc : - From.Parsetree.structure_item_desc -> - To.Parsetree.structure_item_desc - = - function - | From.Parsetree.Pstr_eval (x0,x1) -> - To.Parsetree.Pstr_eval - ((copy_expression x0), - (copy_attributes x1)) - | From.Parsetree.Pstr_value (x0,x1) -> - To.Parsetree.Pstr_value - ((copy_rec_flag x0), - (List.map copy_value_binding x1)) - | From.Parsetree.Pstr_primitive x0 -> - To.Parsetree.Pstr_primitive - (copy_value_description x0) - | From.Parsetree.Pstr_type (x0,x1) -> - To.Parsetree.Pstr_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Pstr_typext x0 -> - To.Parsetree.Pstr_typext - (copy_type_extension x0) - | From.Parsetree.Pstr_exception x0 -> - let atat, at = List.partition (function - | {Location.txt=("ocaml.deprecated"|"deprecated");_},_ -> false - | _ -> true) x0.pext_attributes - in - let x0 = { x0 with pext_attributes = at } in - To.Parsetree.Pstr_exception - { To.Parsetree.ptyexn_constructor = (copy_extension_constructor x0); - To.Parsetree.ptyexn_loc = x0.From.Parsetree.pext_loc; - To.Parsetree.ptyexn_attributes = copy_attributes atat } - | From.Parsetree.Pstr_module x0 -> - To.Parsetree.Pstr_module - (copy_module_binding x0) - | From.Parsetree.Pstr_recmodule x0 -> - To.Parsetree.Pstr_recmodule - (List.map copy_module_binding x0) - | From.Parsetree.Pstr_modtype x0 -> - To.Parsetree.Pstr_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Pstr_open - { From.Parsetree.popen_lid; - From.Parsetree.popen_override; - From.Parsetree.popen_loc; - From.Parsetree.popen_attributes; } -> - To.Parsetree.Pstr_open - { To.Parsetree.popen_expr = - { To.Parsetree.pmod_desc = To.Parsetree.Pmod_ident (copy_loc copy_longident popen_lid); - To.Parsetree.pmod_loc = popen_loc; - To.Parsetree.pmod_attributes = []; }; - To.Parsetree.popen_override = (copy_override_flag popen_override); - To.Parsetree.popen_loc = (copy_location popen_loc); - To.Parsetree.popen_attributes = (copy_attributes popen_attributes); - } - | From.Parsetree.Pstr_class x0 -> - To.Parsetree.Pstr_class - (List.map copy_class_declaration x0) - | From.Parsetree.Pstr_class_type x0 -> - To.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Pstr_include x0 -> - To.Parsetree.Pstr_include - (copy_include_declaration x0) - | From.Parsetree.Pstr_attribute x0 -> - To.Parsetree.Pstr_attribute (copy_attribute x0) - | From.Parsetree.Pstr_extension (x0,x1) -> - To.Parsetree.Pstr_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_include_declaration : - From.Parsetree.include_declaration -> - To.Parsetree.include_declaration - = - fun x -> - copy_include_infos copy_module_expr x - -and copy_class_declaration : - From.Parsetree.class_declaration -> To.Parsetree.class_declaration - = - fun x -> - copy_class_infos copy_class_expr x - -and copy_class_expr : - From.Parsetree.class_expr -> To.Parsetree.class_expr = - fun - { From.Parsetree.pcl_desc = pcl_desc; - From.Parsetree.pcl_loc = pcl_loc; - From.Parsetree.pcl_attributes = pcl_attributes } - -> - { - To.Parsetree.pcl_desc = - (copy_class_expr_desc pcl_desc); - To.Parsetree.pcl_loc = (copy_location pcl_loc); - To.Parsetree.pcl_attributes = - (copy_attributes pcl_attributes) - } - -and copy_class_expr_desc : - From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = - function - | From.Parsetree.Pcl_constr (x0,x1) -> - To.Parsetree.Pcl_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcl_structure x0 -> - To.Parsetree.Pcl_structure - (copy_class_structure x0) - | From.Parsetree.Pcl_fun (x0,x1,x2,x3) -> - To.Parsetree.Pcl_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_class_expr x3)) - | From.Parsetree.Pcl_apply (x0,x1) -> - To.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pcl_let (x0,x1,x2) -> - To.Parsetree.Pcl_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_class_expr x2)) - | From.Parsetree.Pcl_constraint (x0,x1) -> - To.Parsetree.Pcl_constraint - ((copy_class_expr x0), - (copy_class_type x1)) - | From.Parsetree.Pcl_extension x0 -> - To.Parsetree.Pcl_extension (copy_extension x0) - | From.Parsetree.Pcl_open (x0,x1,x2) -> - To.Parsetree.Pcl_open - ({ To.Parsetree.popen_expr = (copy_loc copy_longident x1); - To.Parsetree.popen_override = (copy_override_flag x0); - To.Parsetree.popen_loc = x1.Location.loc; - To.Parsetree.popen_attributes = []; }, - (copy_class_expr x2)) - -and copy_class_structure : - From.Parsetree.class_structure -> To.Parsetree.class_structure = - fun - { From.Parsetree.pcstr_self = pcstr_self; - From.Parsetree.pcstr_fields = pcstr_fields } - -> - let fields = - List.sort - (fun (a : From.Parsetree.class_field) (b : From.Parsetree.class_field) -> - compare a.pcf_loc.loc_start.pos_cnum b.pcf_loc.loc_start.pos_cnum) - pcstr_fields - in - { - To.Parsetree.pcstr_self = - (copy_pattern pcstr_self); - To.Parsetree.pcstr_fields = - (List.map copy_class_field fields) - } - -and copy_class_field : - From.Parsetree.class_field -> To.Parsetree.class_field = - fun - { From.Parsetree.pcf_desc = pcf_desc; - From.Parsetree.pcf_loc = pcf_loc; - From.Parsetree.pcf_attributes = pcf_attributes } - -> - { - To.Parsetree.pcf_desc = - (copy_class_field_desc pcf_desc); - To.Parsetree.pcf_loc = (copy_location pcf_loc); - To.Parsetree.pcf_attributes = - (copy_attributes pcf_attributes) - } - -and copy_class_field_desc : - From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = - function - | From.Parsetree.Pcf_inherit (x0,x1,x2) -> - To.Parsetree.Pcf_inherit - ((copy_override_flag x0), - (copy_class_expr x1), - (copy_option (fun x -> copy_loc (fun x -> x) x) - x2)) - | From.Parsetree.Pcf_val x0 -> - To.Parsetree.Pcf_val - (let (x0,x1,x2) = x0 in - ((copy_loc copy_label x0), - (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_method x0 -> - To.Parsetree.Pcf_method - (let (x0,x1,x2) = x0 in - ((copy_loc copy_label x0), - (copy_private_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_constraint x0 -> - To.Parsetree.Pcf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pcf_initializer x0 -> - To.Parsetree.Pcf_initializer - (copy_expression x0) - | From.Parsetree.Pcf_attribute x0 -> - To.Parsetree.Pcf_attribute (copy_attribute x0) - | From.Parsetree.Pcf_extension x0 -> - To.Parsetree.Pcf_extension (copy_extension x0) - -and copy_class_field_kind : - From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = - function - | From.Parsetree.Cfk_virtual x0 -> - To.Parsetree.Cfk_virtual (copy_core_type x0) - | From.Parsetree.Cfk_concrete (x0,x1) -> - To.Parsetree.Cfk_concrete - ((copy_override_flag x0), - (copy_expression x1)) - -and copy_module_binding : - From.Parsetree.module_binding -> To.Parsetree.module_binding = - fun - { From.Parsetree.pmb_name = pmb_name; - From.Parsetree.pmb_expr = pmb_expr; - From.Parsetree.pmb_attributes = pmb_attributes; - From.Parsetree.pmb_loc = pmb_loc } - -> - { - To.Parsetree.pmb_name = - (copy_loc (fun x -> x) pmb_name); - To.Parsetree.pmb_expr = - (copy_module_expr pmb_expr); - To.Parsetree.pmb_attributes = - (copy_attributes pmb_attributes); - To.Parsetree.pmb_loc = (copy_location pmb_loc) - } - -and copy_module_expr : - From.Parsetree.module_expr -> To.Parsetree.module_expr = - fun - { From.Parsetree.pmod_desc = pmod_desc; - From.Parsetree.pmod_loc = pmod_loc; - From.Parsetree.pmod_attributes = pmod_attributes } - -> - { - To.Parsetree.pmod_desc = - (copy_module_expr_desc pmod_desc); - To.Parsetree.pmod_loc = (copy_location pmod_loc); - To.Parsetree.pmod_attributes = - (copy_attributes pmod_attributes) - } - -and copy_module_expr_desc : - From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = - function - | From.Parsetree.Pmod_ident x0 -> - To.Parsetree.Pmod_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmod_structure x0 -> - To.Parsetree.Pmod_structure (copy_structure x0) - | From.Parsetree.Pmod_functor (x0,x1,x2) -> - To.Parsetree.Pmod_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_expr x2)) - | From.Parsetree.Pmod_apply (x0,x1) -> - To.Parsetree.Pmod_apply - ((copy_module_expr x0), - (copy_module_expr x1)) - | From.Parsetree.Pmod_constraint (x0,x1) -> - To.Parsetree.Pmod_constraint - ((copy_module_expr x0), - (copy_module_type x1)) - | From.Parsetree.Pmod_unpack x0 -> - To.Parsetree.Pmod_unpack (copy_expression x0) - | From.Parsetree.Pmod_extension x0 -> - To.Parsetree.Pmod_extension (copy_extension x0) - -and copy_module_type : - From.Parsetree.module_type -> To.Parsetree.module_type = - fun - { From.Parsetree.pmty_desc = pmty_desc; - From.Parsetree.pmty_loc = pmty_loc; - From.Parsetree.pmty_attributes = pmty_attributes } - -> - { - To.Parsetree.pmty_desc = - (copy_module_type_desc pmty_desc); - To.Parsetree.pmty_loc = (copy_location pmty_loc); - To.Parsetree.pmty_attributes = - (copy_attributes pmty_attributes) - } - -and copy_module_type_desc : - From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = - function - | From.Parsetree.Pmty_ident x0 -> - To.Parsetree.Pmty_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmty_signature x0 -> - To.Parsetree.Pmty_signature (copy_signature x0) - | From.Parsetree.Pmty_functor (x0,x1,x2) -> - To.Parsetree.Pmty_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_type x2)) - | From.Parsetree.Pmty_with (x0,x1) -> - To.Parsetree.Pmty_with - ((copy_module_type x0), - (List.map copy_with_constraint x1)) - | From.Parsetree.Pmty_typeof x0 -> - To.Parsetree.Pmty_typeof (copy_module_expr x0) - | From.Parsetree.Pmty_extension x0 -> - To.Parsetree.Pmty_extension (copy_extension x0) - | From.Parsetree.Pmty_alias x0 -> - To.Parsetree.Pmty_alias - (copy_loc copy_longident x0) - -and copy_with_constraint : - From.Parsetree.with_constraint -> To.Parsetree.with_constraint = - function - | From.Parsetree.Pwith_type (x0,x1) -> - To.Parsetree.Pwith_type - ((copy_loc copy_longident x0), - (copy_type_declaration x1)) - | From.Parsetree.Pwith_module (x0,x1) -> - To.Parsetree.Pwith_module - ((copy_loc copy_longident x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pwith_typesubst (x0,x1) -> - To.Parsetree.Pwith_typesubst - ((copy_loc copy_longident x0), - (copy_type_declaration x1)) - | From.Parsetree.Pwith_modsubst (x0,x1) -> - To.Parsetree.Pwith_modsubst - ((copy_loc copy_longident x0), - (copy_loc copy_longident x1)) - -and copy_signature : - From.Parsetree.signature -> To.Parsetree.signature = - fun x -> List.map copy_signature_item x - -and copy_signature_item : - From.Parsetree.signature_item -> To.Parsetree.signature_item = - fun - { From.Parsetree.psig_desc = psig_desc; - From.Parsetree.psig_loc = psig_loc } - -> - { - To.Parsetree.psig_desc = - (copy_signature_item_desc psig_desc); - To.Parsetree.psig_loc = (copy_location psig_loc) - } - -and copy_signature_item_desc : - From.Parsetree.signature_item_desc -> - To.Parsetree.signature_item_desc - = - function - | From.Parsetree.Psig_value x0 -> - To.Parsetree.Psig_value - (copy_value_description x0) - | From.Parsetree.Psig_type (x0,x1) -> - To.Parsetree.Psig_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Psig_typext x0 -> - To.Parsetree.Psig_typext - (copy_type_extension x0) - | From.Parsetree.Psig_exception x0 -> - let atat, at = List.partition (function - | {Location.txt=("ocaml.deprecated"|"deprecated");_},_ -> false - | _ -> true) x0.pext_attributes - in - let x0 = { x0 with pext_attributes = at } in - - To.Parsetree.Psig_exception - { To.Parsetree.ptyexn_constructor = (copy_extension_constructor x0); - To.Parsetree.ptyexn_loc = x0.From.Parsetree.pext_loc; - To.Parsetree.ptyexn_attributes = copy_attributes atat; } - | From.Parsetree.Psig_module x0 -> - To.Parsetree.Psig_module - (copy_module_declaration x0) - | From.Parsetree.Psig_recmodule x0 -> - To.Parsetree.Psig_recmodule - (List.map copy_module_declaration x0) - | From.Parsetree.Psig_modtype x0 -> - To.Parsetree.Psig_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Psig_open x0 -> - To.Parsetree.Psig_open - (copy_open_description x0) - | From.Parsetree.Psig_include x0 -> - To.Parsetree.Psig_include - (copy_include_description x0) - | From.Parsetree.Psig_class x0 -> - To.Parsetree.Psig_class - (List.map copy_class_description x0) - | From.Parsetree.Psig_class_type x0 -> - To.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Psig_attribute x0 -> - To.Parsetree.Psig_attribute (copy_attribute x0) - | From.Parsetree.Psig_extension (x0,x1) -> - To.Parsetree.Psig_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_class_type_declaration : - From.Parsetree.class_type_declaration -> - To.Parsetree.class_type_declaration - = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_description : - From.Parsetree.class_description -> To.Parsetree.class_description +let rec copy_out_type_extension : + Ast_407.Outcometree.out_type_extension -> + Ast_408.Outcometree.out_type_extension = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_type : - From.Parsetree.class_type -> To.Parsetree.class_type = - fun - { From.Parsetree.pcty_desc = pcty_desc; - From.Parsetree.pcty_loc = pcty_loc; - From.Parsetree.pcty_attributes = pcty_attributes } - -> - { - To.Parsetree.pcty_desc = - (copy_class_type_desc pcty_desc); - To.Parsetree.pcty_loc = (copy_location pcty_loc); - To.Parsetree.pcty_attributes = - (copy_attributes pcty_attributes) - } - -and copy_class_type_desc : - From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = - function - | From.Parsetree.Pcty_constr (x0,x1) -> - To.Parsetree.Pcty_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcty_signature x0 -> - To.Parsetree.Pcty_signature - (copy_class_signature x0) - | From.Parsetree.Pcty_arrow (x0,x1,x2) -> - To.Parsetree.Pcty_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_class_type x2)) - | From.Parsetree.Pcty_extension x0 -> - To.Parsetree.Pcty_extension (copy_extension x0) - | From.Parsetree.Pcty_open (x0,x1,x2) -> - To.Parsetree.Pcty_open - ({ To.Parsetree.popen_expr = (copy_loc copy_longident x1); - To.Parsetree.popen_override = (copy_override_flag x0); - To.Parsetree.popen_loc = x1.Location.loc; - To.Parsetree.popen_attributes = []; }, - (copy_class_type x2)) - -and copy_class_signature : - From.Parsetree.class_signature -> To.Parsetree.class_signature = fun - { From.Parsetree.pcsig_self = pcsig_self; - From.Parsetree.pcsig_fields = pcsig_fields } + { Ast_407.Outcometree.otyext_name = otyext_name; + Ast_407.Outcometree.otyext_params = otyext_params; + Ast_407.Outcometree.otyext_constructors = otyext_constructors; + Ast_407.Outcometree.otyext_private = otyext_private } -> - let fields = - List.sort - (fun (a : From.Parsetree.class_type_field) (b : From.Parsetree.class_type_field) -> - compare a.pctf_loc.loc_start.pos_cnum b.pctf_loc.loc_start.pos_cnum) - pcsig_fields - in - { - To.Parsetree.pcsig_self = - (copy_core_type pcsig_self); - To.Parsetree.pcsig_fields = - (List.map copy_class_type_field fields) - } - -and copy_class_type_field : - From.Parsetree.class_type_field -> To.Parsetree.class_type_field = - fun - { From.Parsetree.pctf_desc = pctf_desc; - From.Parsetree.pctf_loc = pctf_loc; - From.Parsetree.pctf_attributes = pctf_attributes } - -> - { - To.Parsetree.pctf_desc = - (copy_class_type_field_desc pctf_desc); - To.Parsetree.pctf_loc = (copy_location pctf_loc); - To.Parsetree.pctf_attributes = - (copy_attributes pctf_attributes) - } - -and copy_class_type_field_desc : - From.Parsetree.class_type_field_desc -> - To.Parsetree.class_type_field_desc - = - function - | From.Parsetree.Pctf_inherit x0 -> - To.Parsetree.Pctf_inherit (copy_class_type x0) - | From.Parsetree.Pctf_val x0 -> - To.Parsetree.Pctf_val - (let (x0,x1,x2,x3) = x0 in - ((copy_loc copy_label x0), - (copy_mutable_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_method x0 -> - To.Parsetree.Pctf_method - (let (x0,x1,x2,x3) = x0 in - ((copy_loc copy_label x0), - (copy_private_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_constraint x0 -> - To.Parsetree.Pctf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pctf_attribute x0 -> - To.Parsetree.Pctf_attribute (copy_attribute x0) - | From.Parsetree.Pctf_extension x0 -> - To.Parsetree.Pctf_extension (copy_extension x0) - -and copy_extension : - From.Parsetree.extension -> To.Parsetree.extension = - fun x -> - let (x0,x1) = x in - let x1 = - match x0.txt with - | "ocaml.error" | "error" -> - begin match x1 with - | PStr (hd :: _ :: tl) -> From.Parsetree.PStr (hd :: tl) - | _ -> x1 - end - | _ -> x1 in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.class_infos -> 'g0 To.Parsetree.class_infos - = - fun f0 -> - fun - { From.Parsetree.pci_virt = pci_virt; - From.Parsetree.pci_params = pci_params; - From.Parsetree.pci_name = pci_name; - From.Parsetree.pci_expr = pci_expr; - From.Parsetree.pci_loc = pci_loc; - From.Parsetree.pci_attributes = pci_attributes } - -> - { - To.Parsetree.pci_virt = - (copy_virtual_flag pci_virt); - To.Parsetree.pci_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) pci_params); - To.Parsetree.pci_name = - (copy_loc (fun x -> x) pci_name); - To.Parsetree.pci_expr = (f0 pci_expr); - To.Parsetree.pci_loc = (copy_location pci_loc); - To.Parsetree.pci_attributes = - (copy_attributes pci_attributes) - } - -and copy_virtual_flag : - From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = - function - | From.Asttypes.Virtual -> To.Asttypes.Virtual - | From.Asttypes.Concrete -> To.Asttypes.Concrete - -and copy_include_description : - From.Parsetree.include_description -> - To.Parsetree.include_description - = - fun x -> - copy_include_infos copy_module_type x - -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.include_infos -> - 'g0 To.Parsetree.include_infos - = - fun f0 -> - fun - { From.Parsetree.pincl_mod = pincl_mod; - From.Parsetree.pincl_loc = pincl_loc; - From.Parsetree.pincl_attributes = pincl_attributes } - -> - { - To.Parsetree.pincl_mod = (f0 pincl_mod); - To.Parsetree.pincl_loc = (copy_location pincl_loc); - To.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } - -and copy_open_description : - From.Parsetree.open_description -> To.Parsetree.open_description = - fun - { From.Parsetree.popen_lid = popen_lid; - From.Parsetree.popen_override = popen_override; - From.Parsetree.popen_loc = popen_loc; - From.Parsetree.popen_attributes = popen_attributes } - -> - { - To.Parsetree.popen_expr = - (copy_loc copy_longident popen_lid); - To.Parsetree.popen_override = - (copy_override_flag popen_override); - To.Parsetree.popen_loc = (copy_location popen_loc); - To.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } - -and copy_override_flag : - From.Asttypes.override_flag -> To.Asttypes.override_flag = - function - | From.Asttypes.Override -> To.Asttypes.Override - | From.Asttypes.Fresh -> To.Asttypes.Fresh - -and copy_module_type_declaration : - From.Parsetree.module_type_declaration -> - To.Parsetree.module_type_declaration - = - fun - { From.Parsetree.pmtd_name = pmtd_name; - From.Parsetree.pmtd_type = pmtd_type; - From.Parsetree.pmtd_attributes = pmtd_attributes; - From.Parsetree.pmtd_loc = pmtd_loc } - -> - { - To.Parsetree.pmtd_name = - (copy_loc (fun x -> x) pmtd_name); - To.Parsetree.pmtd_type = - (copy_option copy_module_type pmtd_type); - To.Parsetree.pmtd_attributes = - (copy_attributes pmtd_attributes); - To.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } - -and copy_module_declaration : - From.Parsetree.module_declaration -> - To.Parsetree.module_declaration - = - fun - { From.Parsetree.pmd_name = pmd_name; - From.Parsetree.pmd_type = pmd_type; - From.Parsetree.pmd_attributes = pmd_attributes; - From.Parsetree.pmd_loc = pmd_loc } - -> - { - To.Parsetree.pmd_name = - (copy_loc (fun x -> x) pmd_name); - To.Parsetree.pmd_type = - (copy_module_type pmd_type); - To.Parsetree.pmd_attributes = - (copy_attributes pmd_attributes); - To.Parsetree.pmd_loc = (copy_location pmd_loc) - } - -and copy_type_extension : - From.Parsetree.type_extension -> To.Parsetree.type_extension = - fun - { From.Parsetree.ptyext_path = ptyext_path; - From.Parsetree.ptyext_params = ptyext_params; - From.Parsetree.ptyext_constructors = ptyext_constructors; - From.Parsetree.ptyext_private = ptyext_private; - From.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - To.Parsetree.ptyext_path = - (copy_loc copy_longident ptyext_path); - To.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptyext_params); - To.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor - ptyext_constructors); - To.Parsetree.ptyext_private = - (copy_private_flag ptyext_private); - To.Parsetree.ptyext_loc = ptyext_path.Location.loc; - To.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } - -and copy_extension_constructor : - From.Parsetree.extension_constructor -> - To.Parsetree.extension_constructor - = - fun - { From.Parsetree.pext_name = pext_name; - From.Parsetree.pext_kind = pext_kind; - From.Parsetree.pext_loc = pext_loc; - From.Parsetree.pext_attributes = pext_attributes } - -> - { - To.Parsetree.pext_name = - (copy_loc (fun x -> x) pext_name); - To.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - To.Parsetree.pext_loc = (copy_location pext_loc); - To.Parsetree.pext_attributes = - (copy_attributes pext_attributes) - } - -and copy_extension_constructor_kind : - From.Parsetree.extension_constructor_kind -> - To.Parsetree.extension_constructor_kind - = - function - | From.Parsetree.Pext_decl (x0,x1) -> - To.Parsetree.Pext_decl - ((copy_constructor_arguments x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pext_rebind x0 -> - To.Parsetree.Pext_rebind - (copy_loc copy_longident x0) - -and copy_type_declaration : - From.Parsetree.type_declaration -> To.Parsetree.type_declaration = - fun - { From.Parsetree.ptype_name = ptype_name; - From.Parsetree.ptype_params = ptype_params; - From.Parsetree.ptype_cstrs = ptype_cstrs; - From.Parsetree.ptype_kind = ptype_kind; - From.Parsetree.ptype_private = ptype_private; - From.Parsetree.ptype_manifest = ptype_manifest; - From.Parsetree.ptype_attributes = ptype_attributes; - From.Parsetree.ptype_loc = ptype_loc } - -> - { - To.Parsetree.ptype_name = - (copy_loc (fun x -> x) ptype_name); - To.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptype_params); - To.Parsetree.ptype_cstrs = + Ast_408.Outcometree.otyext_name = otyext_name; + Ast_408.Outcometree.otyext_params = + (List.map (fun x -> x) otyext_params); + Ast_408.Outcometree.otyext_constructors = (List.map - (fun x -> - let (x0,x1,x2) = x in - ((copy_core_type x0), - (copy_core_type x1), - (copy_location x2))) ptype_cstrs); - To.Parsetree.ptype_kind = - (copy_type_kind ptype_kind); - To.Parsetree.ptype_private = - (copy_private_flag ptype_private); - To.Parsetree.ptype_manifest = - (copy_option copy_core_type ptype_manifest); - To.Parsetree.ptype_attributes = - (copy_attributes ptype_attributes); - To.Parsetree.ptype_loc = (copy_location ptype_loc) - } - -and copy_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = - function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - -and copy_type_kind : - From.Parsetree.type_kind -> To.Parsetree.type_kind = - function - | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract - | From.Parsetree.Ptype_variant x0 -> - To.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | From.Parsetree.Ptype_record x0 -> - To.Parsetree.Ptype_record - (List.map copy_label_declaration x0) - | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open - -and copy_constructor_declaration : - From.Parsetree.constructor_declaration -> - To.Parsetree.constructor_declaration - = - fun - { From.Parsetree.pcd_name = pcd_name; - From.Parsetree.pcd_args = pcd_args; - From.Parsetree.pcd_res = pcd_res; - From.Parsetree.pcd_loc = pcd_loc; - From.Parsetree.pcd_attributes = pcd_attributes } - -> - { - To.Parsetree.pcd_name = - (copy_loc (fun x -> x) pcd_name); - To.Parsetree.pcd_args = - (copy_constructor_arguments pcd_args); - To.Parsetree.pcd_res = - (copy_option copy_core_type pcd_res); - To.Parsetree.pcd_loc = (copy_location pcd_loc); - To.Parsetree.pcd_attributes = - (copy_attributes pcd_attributes) - } - -and copy_constructor_arguments : - From.Parsetree.constructor_arguments -> - To.Parsetree.constructor_arguments - = - function - | From.Parsetree.Pcstr_tuple x0 -> - To.Parsetree.Pcstr_tuple - (List.map copy_core_type x0) - | From.Parsetree.Pcstr_record x0 -> - To.Parsetree.Pcstr_record - (List.map copy_label_declaration x0) - -and copy_label_declaration : - From.Parsetree.label_declaration -> To.Parsetree.label_declaration - = - fun - { From.Parsetree.pld_name = pld_name; - From.Parsetree.pld_mutable = pld_mutable; - From.Parsetree.pld_type = pld_type; - From.Parsetree.pld_loc = pld_loc; - From.Parsetree.pld_attributes = pld_attributes } - -> - { - To.Parsetree.pld_name = - (copy_loc (fun x -> x) pld_name); - To.Parsetree.pld_mutable = - (copy_mutable_flag pld_mutable); - To.Parsetree.pld_type = - (copy_core_type pld_type); - To.Parsetree.pld_loc = (copy_location pld_loc); - To.Parsetree.pld_attributes = - (copy_attributes pld_attributes) - } - -and copy_mutable_flag : - From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = - function - | From.Asttypes.Immutable -> To.Asttypes.Immutable - | From.Asttypes.Mutable -> To.Asttypes.Mutable - -and copy_variance : - From.Asttypes.variance -> To.Asttypes.variance = - function - | From.Asttypes.Covariant -> To.Asttypes.Covariant - | From.Asttypes.Contravariant -> To.Asttypes.Contravariant - | From.Asttypes.Invariant -> To.Asttypes.Invariant - -and copy_value_description : - From.Parsetree.value_description -> To.Parsetree.value_description - = - fun - { From.Parsetree.pval_name = pval_name; - From.Parsetree.pval_type = pval_type; - From.Parsetree.pval_prim = pval_prim; - From.Parsetree.pval_attributes = pval_attributes; - From.Parsetree.pval_loc = pval_loc } - -> - { - To.Parsetree.pval_name = - (copy_loc (fun x -> x) pval_name); - To.Parsetree.pval_type = - (copy_core_type pval_type); - To.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - To.Parsetree.pval_attributes = - (copy_attributes pval_attributes); - To.Parsetree.pval_loc = (copy_location pval_loc) - } - -and copy_arg_label : - From.Asttypes.arg_label -> To.Asttypes.arg_label = - function - | From.Asttypes.Nolabel -> To.Asttypes.Nolabel - | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 - | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 - -and copy_closed_flag : - From.Asttypes.closed_flag -> To.Asttypes.closed_flag = - function - | From.Asttypes.Closed -> To.Asttypes.Closed - | From.Asttypes.Open -> To.Asttypes.Open - -and copy_label : - From.Asttypes.label -> To.Asttypes.label = fun x -> x - -and copy_rec_flag : - From.Asttypes.rec_flag -> To.Asttypes.rec_flag = - function - | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive - | From.Asttypes.Recursive -> To.Asttypes.Recursive - -and copy_constant : - From.Parsetree.constant -> To.Parsetree.constant = - function - | From.Parsetree.Pconst_integer (x0,x1) -> - To.Parsetree.Pconst_integer (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 - | From.Parsetree.Pconst_string (x0,x1) -> - To.Parsetree.Pconst_string (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_float (x0,x1) -> - To.Parsetree.Pconst_float (x0, (copy_option (fun x -> x) x1)) - -and copy_option : 'f0 'g0 . ('f0 -> 'g0) -> 'f0 option -> 'g0 option = - fun f0 -> function | None -> None | Some x0 -> Some (f0 x0) - -and copy_longident : From.Longident.t -> To.Longident.t = - function - | From.Longident.Lident x0 -> To.Longident.Lident x0 - | From.Longident.Ldot (x0,x1) -> - To.Longident.Ldot ((copy_longident x0), x1) - | From.Longident.Lapply (x0,x1) -> - To.Longident.Lapply - ((copy_longident x0), (copy_longident x1)) - -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc - = - fun f0 -> - fun { From.Asttypes.txt = txt; From.Asttypes.loc = loc } -> - { - To.Asttypes.txt = (f0 txt); - To.Asttypes.loc = (copy_location loc) - } - -and copy_location : From.Location.t -> To.Location.t = - fun - { From.Location.loc_start = loc_start; - From.Location.loc_end = loc_end; - From.Location.loc_ghost = loc_ghost } - -> - { - To.Location.loc_start = (copy_Lexing_position loc_start); - To.Location.loc_end = (copy_Lexing_position loc_end); - To.Location.loc_ghost = (copy_bool loc_ghost) - } - -and copy_bool : bool -> bool = function | false -> false | true -> true - -and copy_Lexing_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum + (fun x -> + let (x0, x1, x2) = x in + (x0, (List.map copy_out_type x1), + (Option.map copy_out_type x2))) otyext_constructors); + Ast_408.Outcometree.otyext_private = (copy_private_flag otyext_private) } - -let copy_cases x = List.map copy_case x -let copy_pat = copy_pattern -let copy_expr = copy_expression -let copy_typ = copy_core_type - -let rec copy_out_phrase : - From.Outcometree.out_phrase -> To.Outcometree.out_phrase = +and copy_out_phrase : + Ast_407.Outcometree.out_phrase -> Ast_408.Outcometree.out_phrase = function - | From.Outcometree.Ophr_eval (x0,x1) -> - To.Outcometree.Ophr_eval - ((copy_out_value x0), - (copy_out_type x1)) - | From.Outcometree.Ophr_signature x0 -> - To.Outcometree.Ophr_signature + | Ast_407.Outcometree.Ophr_eval (x0, x1) -> + Ast_408.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1)) + | Ast_407.Outcometree.Ophr_signature x0 -> + Ast_408.Outcometree.Ophr_signature (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_sig_item x0), - (copy_option copy_out_value x1))) x0) - | From.Outcometree.Ophr_exception x0 -> - To.Outcometree.Ophr_exception - (let (x0,x1) = x0 in - ((copy_exn x0), (copy_out_value x1))) - -and copy_exn : exn -> exn = fun x -> x - + (fun x -> + let (x0, x1) = x in + ((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0) + | Ast_407.Outcometree.Ophr_exception x0 -> + Ast_408.Outcometree.Ophr_exception + (let (x0, x1) = x0 in (x0, (copy_out_value x1))) and copy_out_sig_item : - From.Outcometree.out_sig_item -> To.Outcometree.out_sig_item = + Ast_407.Outcometree.out_sig_item -> Ast_408.Outcometree.out_sig_item = function - | From.Outcometree.Osig_class (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class - ((copy_bool x0), x1, + | Ast_407.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> + Ast_408.Outcometree.Osig_class + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_class_type (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class_type - ((copy_bool x0), x1, + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_407.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> + Ast_408.Outcometree.Osig_class_type + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_typext (x0,x1) -> - To.Outcometree.Osig_typext - ((copy_out_extension_constructor x0), - (copy_out_ext_status x1)) - | From.Outcometree.Osig_modtype (x0,x1) -> - To.Outcometree.Osig_modtype - (x0, (copy_out_module_type x1)) - | From.Outcometree.Osig_module (x0,x1,x2) -> - To.Outcometree.Osig_module - (x0, (copy_out_module_type x1), - (copy_out_rec_status x2)) - | From.Outcometree.Osig_type (x0,x1) -> - To.Outcometree.Osig_type - ((copy_out_type_decl x0), - (copy_out_rec_status x1)) - | From.Outcometree.Osig_value x0 -> - To.Outcometree.Osig_value - (copy_out_val_decl x0) - | From.Outcometree.Osig_ellipsis -> To.Outcometree.Osig_ellipsis - + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_407.Outcometree.Osig_typext (x0, x1) -> + Ast_408.Outcometree.Osig_typext + ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) + | Ast_407.Outcometree.Osig_modtype (x0, x1) -> + Ast_408.Outcometree.Osig_modtype (x0, (copy_out_module_type x1)) + | Ast_407.Outcometree.Osig_module (x0, x1, x2) -> + Ast_408.Outcometree.Osig_module + (x0, (copy_out_module_type x1), (copy_out_rec_status x2)) + | Ast_407.Outcometree.Osig_type (x0, x1) -> + Ast_408.Outcometree.Osig_type + ((copy_out_type_decl x0), (copy_out_rec_status x1)) + | Ast_407.Outcometree.Osig_value x0 -> + Ast_408.Outcometree.Osig_value (copy_out_val_decl x0) + | Ast_407.Outcometree.Osig_ellipsis -> Ast_408.Outcometree.Osig_ellipsis and copy_out_val_decl : - From.Outcometree.out_val_decl -> To.Outcometree.out_val_decl = + Ast_407.Outcometree.out_val_decl -> Ast_408.Outcometree.out_val_decl = fun - { From.Outcometree.oval_name = oval_name; - From.Outcometree.oval_type = oval_type; - From.Outcometree.oval_prims = oval_prims; - From.Outcometree.oval_attributes = oval_attributes } - -> + { Ast_407.Outcometree.oval_name = oval_name; + Ast_407.Outcometree.oval_type = oval_type; + Ast_407.Outcometree.oval_prims = oval_prims; + Ast_407.Outcometree.oval_attributes = oval_attributes } + -> { - To.Outcometree.oval_name = oval_name; - To.Outcometree.oval_type = - (copy_out_type oval_type); - To.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); - To.Outcometree.oval_attributes = + Ast_408.Outcometree.oval_name = oval_name; + Ast_408.Outcometree.oval_type = (copy_out_type oval_type); + Ast_408.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); + Ast_408.Outcometree.oval_attributes = (List.map copy_out_attribute oval_attributes) } - and copy_out_type_decl : - From.Outcometree.out_type_decl -> To.Outcometree.out_type_decl = + Ast_407.Outcometree.out_type_decl -> Ast_408.Outcometree.out_type_decl = fun - { From.Outcometree.otype_name = otype_name; - From.Outcometree.otype_params = otype_params; - From.Outcometree.otype_type = otype_type; - From.Outcometree.otype_private = otype_private; - From.Outcometree.otype_immediate = otype_immediate; - From.Outcometree.otype_unboxed = otype_unboxed; - From.Outcometree.otype_cstrs = otype_cstrs } - -> + { Ast_407.Outcometree.otype_name = otype_name; + Ast_407.Outcometree.otype_params = otype_params; + Ast_407.Outcometree.otype_type = otype_type; + Ast_407.Outcometree.otype_private = otype_private; + Ast_407.Outcometree.otype_immediate = otype_immediate; + Ast_407.Outcometree.otype_unboxed = otype_unboxed; + Ast_407.Outcometree.otype_cstrs = otype_cstrs } + -> { - To.Outcometree.otype_name = otype_name; - To.Outcometree.otype_params = + Ast_408.Outcometree.otype_name = otype_name; + Ast_408.Outcometree.otype_params = (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) otype_params); - To.Outcometree.otype_type = - (copy_out_type otype_type); - To.Outcometree.otype_private = - (copy_From_Asttypes_private_flag otype_private); - To.Outcometree.otype_immediate = (copy_bool otype_immediate); - To.Outcometree.otype_unboxed = (copy_bool otype_unboxed); - To.Outcometree.otype_cstrs = + Ast_408.Outcometree.otype_type = (copy_out_type otype_type); + Ast_408.Outcometree.otype_private = (copy_private_flag otype_private); + Ast_408.Outcometree.otype_immediate = otype_immediate; + Ast_408.Outcometree.otype_unboxed = otype_unboxed; + Ast_408.Outcometree.otype_cstrs = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_type x0), - (copy_out_type x1))) otype_cstrs) + (fun x -> + let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1))) + otype_cstrs) } - and copy_out_module_type : - From.Outcometree.out_module_type -> To.Outcometree.out_module_type + Ast_407.Outcometree.out_module_type -> Ast_408.Outcometree.out_module_type = function - | From.Outcometree.Omty_abstract -> To.Outcometree.Omty_abstract - | From.Outcometree.Omty_functor (x0,x1,x2) -> - To.Outcometree.Omty_functor - (x0, (copy_option copy_out_module_type x1), - (copy_out_module_type x2)) - | From.Outcometree.Omty_ident x0 -> - To.Outcometree.Omty_ident (copy_out_ident x0) - | From.Outcometree.Omty_signature x0 -> - To.Outcometree.Omty_signature - (List.map copy_out_sig_item x0) - | From.Outcometree.Omty_alias x0 -> - To.Outcometree.Omty_alias (copy_out_ident x0) - + | Ast_407.Outcometree.Omty_abstract -> Ast_408.Outcometree.Omty_abstract + | Ast_407.Outcometree.Omty_functor (x0, x1, x2) -> + Ast_408.Outcometree.Omty_functor + (x0, (Option.map copy_out_module_type x1), (copy_out_module_type x2)) + | Ast_407.Outcometree.Omty_ident x0 -> + Ast_408.Outcometree.Omty_ident (copy_out_ident x0) + | Ast_407.Outcometree.Omty_signature x0 -> + Ast_408.Outcometree.Omty_signature (List.map copy_out_sig_item x0) + | Ast_407.Outcometree.Omty_alias x0 -> + Ast_408.Outcometree.Omty_alias (copy_out_ident x0) and copy_out_ext_status : - From.Outcometree.out_ext_status -> To.Outcometree.out_ext_status = + Ast_407.Outcometree.out_ext_status -> Ast_408.Outcometree.out_ext_status = function - | From.Outcometree.Oext_first -> To.Outcometree.Oext_first - | From.Outcometree.Oext_next -> To.Outcometree.Oext_next - | From.Outcometree.Oext_exception -> To.Outcometree.Oext_exception - + | Ast_407.Outcometree.Oext_first -> Ast_408.Outcometree.Oext_first + | Ast_407.Outcometree.Oext_next -> Ast_408.Outcometree.Oext_next + | Ast_407.Outcometree.Oext_exception -> Ast_408.Outcometree.Oext_exception and copy_out_extension_constructor : - From.Outcometree.out_extension_constructor -> - To.Outcometree.out_extension_constructor + Ast_407.Outcometree.out_extension_constructor -> + Ast_408.Outcometree.out_extension_constructor = fun - { From.Outcometree.oext_name = oext_name; - From.Outcometree.oext_type_name = oext_type_name; - From.Outcometree.oext_type_params = oext_type_params; - From.Outcometree.oext_args = oext_args; - From.Outcometree.oext_ret_type = oext_ret_type; - From.Outcometree.oext_private = oext_private } - -> + { Ast_407.Outcometree.oext_name = oext_name; + Ast_407.Outcometree.oext_type_name = oext_type_name; + Ast_407.Outcometree.oext_type_params = oext_type_params; + Ast_407.Outcometree.oext_args = oext_args; + Ast_407.Outcometree.oext_ret_type = oext_ret_type; + Ast_407.Outcometree.oext_private = oext_private } + -> { - To.Outcometree.oext_name = oext_name; - To.Outcometree.oext_type_name = oext_type_name; - To.Outcometree.oext_type_params = - (List.map (fun x -> x) oext_type_params); - To.Outcometree.oext_args = - (List.map copy_out_type oext_args); - To.Outcometree.oext_ret_type = - (copy_option copy_out_type oext_ret_type); - To.Outcometree.oext_private = - (copy_From_Asttypes_private_flag oext_private) + Ast_408.Outcometree.oext_name = oext_name; + Ast_408.Outcometree.oext_type_name = oext_type_name; + Ast_408.Outcometree.oext_type_params = + (List.map (fun x -> x) oext_type_params); + Ast_408.Outcometree.oext_args = (List.map copy_out_type oext_args); + Ast_408.Outcometree.oext_ret_type = + (Option.map copy_out_type oext_ret_type); + Ast_408.Outcometree.oext_private = (copy_private_flag oext_private) } - -and copy_From_Asttypes_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = +and copy_private_flag : + Ast_407.Asttypes.private_flag -> Ast_408.Asttypes.private_flag = function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - + | Ast_407.Asttypes.Private -> Ast_408.Asttypes.Private + | Ast_407.Asttypes.Public -> Ast_408.Asttypes.Public and copy_out_rec_status : - From.Outcometree.out_rec_status -> To.Outcometree.out_rec_status = + Ast_407.Outcometree.out_rec_status -> Ast_408.Outcometree.out_rec_status = function - | From.Outcometree.Orec_not -> To.Outcometree.Orec_not - | From.Outcometree.Orec_first -> To.Outcometree.Orec_first - | From.Outcometree.Orec_next -> To.Outcometree.Orec_next - + | Ast_407.Outcometree.Orec_not -> Ast_408.Outcometree.Orec_not + | Ast_407.Outcometree.Orec_first -> Ast_408.Outcometree.Orec_first + | Ast_407.Outcometree.Orec_next -> Ast_408.Outcometree.Orec_next and copy_out_class_type : - From.Outcometree.out_class_type -> To.Outcometree.out_class_type = - function - | From.Outcometree.Octy_constr (x0,x1) -> - To.Outcometree.Octy_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Octy_arrow (x0,x1,x2) -> - To.Outcometree.Octy_arrow - (x0, (copy_out_type x1), - (copy_out_class_type x2)) - | From.Outcometree.Octy_signature (x0,x1) -> - To.Outcometree.Octy_signature - ((copy_option copy_out_type x0), + Ast_407.Outcometree.out_class_type -> Ast_408.Outcometree.out_class_type = + function + | Ast_407.Outcometree.Octy_constr (x0, x1) -> + Ast_408.Outcometree.Octy_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_407.Outcometree.Octy_arrow (x0, x1, x2) -> + Ast_408.Outcometree.Octy_arrow + (x0, (copy_out_type x1), (copy_out_class_type x2)) + | Ast_407.Outcometree.Octy_signature (x0, x1) -> + Ast_408.Outcometree.Octy_signature + ((Option.map copy_out_type x0), (List.map copy_out_class_sig_item x1)) - and copy_out_class_sig_item : - From.Outcometree.out_class_sig_item -> - To.Outcometree.out_class_sig_item + Ast_407.Outcometree.out_class_sig_item -> + Ast_408.Outcometree.out_class_sig_item = function - | From.Outcometree.Ocsg_constraint (x0,x1) -> - To.Outcometree.Ocsg_constraint - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Ocsg_method (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_method - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - | From.Outcometree.Ocsg_value (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_value - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - + | Ast_407.Outcometree.Ocsg_constraint (x0, x1) -> + Ast_408.Outcometree.Ocsg_constraint + ((copy_out_type x0), (copy_out_type x1)) + | Ast_407.Outcometree.Ocsg_method (x0, x1, x2, x3) -> + Ast_408.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3)) + | Ast_407.Outcometree.Ocsg_value (x0, x1, x2, x3) -> + Ast_408.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3)) and copy_out_type : - From.Outcometree.out_type -> To.Outcometree.out_type = - function - | From.Outcometree.Otyp_abstract -> To.Outcometree.Otyp_abstract - | From.Outcometree.Otyp_open -> To.Outcometree.Otyp_open - | From.Outcometree.Otyp_alias (x0,x1) -> - To.Outcometree.Otyp_alias - ((copy_out_type x0), x1) - | From.Outcometree.Otyp_arrow (x0,x1,x2) -> - To.Outcometree.Otyp_arrow - (x0, (copy_out_type x1), - (copy_out_type x2)) - | From.Outcometree.Otyp_class (x0,x1,x2) -> - To.Outcometree.Otyp_class - ((copy_bool x0), (copy_out_ident x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_constr (x0,x1) -> - To.Outcometree.Otyp_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Otyp_manifest (x0,x1) -> - To.Outcometree.Otyp_manifest - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Otyp_object (x0,x1) -> - To.Outcometree.Otyp_object - ((List.map - (fun x -> - let (x0,x1) = x in - (x0, (copy_out_type x1))) x0), - (copy_option copy_bool x1)) - | From.Outcometree.Otyp_record x0 -> - To.Outcometree.Otyp_record + Ast_407.Outcometree.out_type -> Ast_408.Outcometree.out_type = + function + | Ast_407.Outcometree.Otyp_abstract -> Ast_408.Outcometree.Otyp_abstract + | Ast_407.Outcometree.Otyp_open -> Ast_408.Outcometree.Otyp_open + | Ast_407.Outcometree.Otyp_alias (x0, x1) -> + Ast_408.Outcometree.Otyp_alias ((copy_out_type x0), x1) + | Ast_407.Outcometree.Otyp_arrow (x0, x1, x2) -> + Ast_408.Outcometree.Otyp_arrow + (x0, (copy_out_type x1), (copy_out_type x2)) + | Ast_407.Outcometree.Otyp_class (x0, x1, x2) -> + Ast_408.Outcometree.Otyp_class + (x0, (copy_out_ident x1), (List.map copy_out_type x2)) + | Ast_407.Outcometree.Otyp_constr (x0, x1) -> + Ast_408.Outcometree.Otyp_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_407.Outcometree.Otyp_manifest (x0, x1) -> + Ast_408.Outcometree.Otyp_manifest + ((copy_out_type x0), (copy_out_type x1)) + | Ast_407.Outcometree.Otyp_object (x0, x1) -> + Ast_408.Outcometree.Otyp_object + ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0), + (Option.map (fun x -> x) x1)) + | Ast_407.Outcometree.Otyp_record x0 -> + Ast_408.Outcometree.Otyp_record (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), (copy_out_type x2))) - x0) - | From.Outcometree.Otyp_stuff x0 -> To.Outcometree.Otyp_stuff x0 - | From.Outcometree.Otyp_sum x0 -> - To.Outcometree.Otyp_sum + (fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0) + | Ast_407.Outcometree.Otyp_stuff x0 -> Ast_408.Outcometree.Otyp_stuff x0 + | Ast_407.Outcometree.Otyp_sum x0 -> + Ast_408.Outcometree.Otyp_sum (List.map - (fun x -> - let (x0,x1,x2) = x in + (fun x -> + let (x0, x1, x2) = x in (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) x0) - | From.Outcometree.Otyp_tuple x0 -> - To.Outcometree.Otyp_tuple - (List.map copy_out_type x0) - | From.Outcometree.Otyp_var (x0,x1) -> - To.Outcometree.Otyp_var ((copy_bool x0), x1) - | From.Outcometree.Otyp_variant (x0,x1,x2,x3) -> - To.Outcometree.Otyp_variant - ((copy_bool x0), (copy_out_variant x1), - (copy_bool x2), - (copy_option (fun x -> List.map (fun x -> x) x) x3)) - | From.Outcometree.Otyp_poly (x0,x1) -> - To.Outcometree.Otyp_poly - ((List.map (fun x -> x) x0), (copy_out_type x1)) + (Option.map copy_out_type x2))) x0) + | Ast_407.Outcometree.Otyp_tuple x0 -> + Ast_408.Outcometree.Otyp_tuple (List.map copy_out_type x0) + | Ast_407.Outcometree.Otyp_var (x0, x1) -> + Ast_408.Outcometree.Otyp_var (x0, x1) + | Ast_407.Outcometree.Otyp_variant (x0, x1, x2, x3) -> + Ast_408.Outcometree.Otyp_variant + (x0, (copy_out_variant x1), x2, + (Option.map (fun x -> List.map (fun x -> x) x) x3)) + | Ast_407.Outcometree.Otyp_poly (x0, x1) -> + Ast_408.Outcometree.Otyp_poly + ((List.map (fun x -> x) x0), (copy_out_type x1)) | From.Outcometree.Otyp_module (x0,x1,x2) -> To.Outcometree.Otyp_module ((To.Outcometree.Oide_ident { To.Outcometree.printed_name = x0; }), (List.map (fun x -> x) x1), (List.map copy_out_type x2)) - | From.Outcometree.Otyp_attribute (x0,x1) -> - To.Outcometree.Otyp_attribute - ((copy_out_type x0), - (copy_out_attribute x1)) - -and copy_out_string : - From.Outcometree.out_string -> To.Outcometree.out_string = - function - | From.Outcometree.Ostr_string -> To.Outcometree.Ostr_string - | From.Outcometree.Ostr_bytes -> To.Outcometree.Ostr_bytes - + | Ast_407.Outcometree.Otyp_attribute (x0, x1) -> + Ast_408.Outcometree.Otyp_attribute + ((copy_out_type x0), (copy_out_attribute x1)) and copy_out_attribute : - From.Outcometree.out_attribute -> To.Outcometree.out_attribute = - fun { From.Outcometree.oattr_name = oattr_name } -> - { To.Outcometree.oattr_name = oattr_name } - + Ast_407.Outcometree.out_attribute -> Ast_408.Outcometree.out_attribute = + fun { Ast_407.Outcometree.oattr_name = oattr_name } -> + { Ast_408.Outcometree.oattr_name = oattr_name } and copy_out_variant : - From.Outcometree.out_variant -> To.Outcometree.out_variant = + Ast_407.Outcometree.out_variant -> Ast_408.Outcometree.out_variant = function - | From.Outcometree.Ovar_fields x0 -> - To.Outcometree.Ovar_fields + | Ast_407.Outcometree.Ovar_fields x0 -> + Ast_408.Outcometree.Ovar_fields (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), - (List.map copy_out_type x2))) x0) - | From.Outcometree.Ovar_typ x0 -> - To.Outcometree.Ovar_typ (copy_out_type x0) - + (fun x -> + let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2))) + x0) + | Ast_407.Outcometree.Ovar_typ x0 -> + Ast_408.Outcometree.Ovar_typ (copy_out_type x0) and copy_out_value : - From.Outcometree.out_value -> To.Outcometree.out_value = - function - | From.Outcometree.Oval_array x0 -> - To.Outcometree.Oval_array - (List.map copy_out_value x0) - | From.Outcometree.Oval_char x0 -> To.Outcometree.Oval_char x0 - | From.Outcometree.Oval_constr (x0,x1) -> - To.Outcometree.Oval_constr - ((copy_out_ident x0), - (List.map copy_out_value x1)) - | From.Outcometree.Oval_ellipsis -> To.Outcometree.Oval_ellipsis - | From.Outcometree.Oval_float x0 -> - To.Outcometree.Oval_float (copy_float x0) - | From.Outcometree.Oval_int x0 -> To.Outcometree.Oval_int x0 - | From.Outcometree.Oval_int32 x0 -> To.Outcometree.Oval_int32 x0 - | From.Outcometree.Oval_int64 x0 -> To.Outcometree.Oval_int64 x0 - | From.Outcometree.Oval_nativeint x0 -> - To.Outcometree.Oval_nativeint x0 - | From.Outcometree.Oval_list x0 -> - To.Outcometree.Oval_list - (List.map copy_out_value x0) - | From.Outcometree.Oval_printer x0 -> - To.Outcometree.Oval_printer x0 - | From.Outcometree.Oval_record x0 -> - To.Outcometree.Oval_record + Ast_407.Outcometree.out_value -> Ast_408.Outcometree.out_value = + function + | Ast_407.Outcometree.Oval_array x0 -> + Ast_408.Outcometree.Oval_array (List.map copy_out_value x0) + | Ast_407.Outcometree.Oval_char x0 -> Ast_408.Outcometree.Oval_char x0 + | Ast_407.Outcometree.Oval_constr (x0, x1) -> + Ast_408.Outcometree.Oval_constr + ((copy_out_ident x0), (List.map copy_out_value x1)) + | Ast_407.Outcometree.Oval_ellipsis -> Ast_408.Outcometree.Oval_ellipsis + | Ast_407.Outcometree.Oval_float x0 -> Ast_408.Outcometree.Oval_float x0 + | Ast_407.Outcometree.Oval_int x0 -> Ast_408.Outcometree.Oval_int x0 + | Ast_407.Outcometree.Oval_int32 x0 -> Ast_408.Outcometree.Oval_int32 x0 + | Ast_407.Outcometree.Oval_int64 x0 -> Ast_408.Outcometree.Oval_int64 x0 + | Ast_407.Outcometree.Oval_nativeint x0 -> + Ast_408.Outcometree.Oval_nativeint x0 + | Ast_407.Outcometree.Oval_list x0 -> + Ast_408.Outcometree.Oval_list (List.map copy_out_value x0) + | Ast_407.Outcometree.Oval_printer x0 -> + Ast_408.Outcometree.Oval_printer x0 + | Ast_407.Outcometree.Oval_record x0 -> + Ast_408.Outcometree.Oval_record (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_ident x0), - (copy_out_value x1))) x0) - | From.Outcometree.Oval_string (x0, x1, x2) -> - To.Outcometree.Oval_string (x0, x1, copy_out_string x2) - | From.Outcometree.Oval_stuff x0 -> To.Outcometree.Oval_stuff x0 - | From.Outcometree.Oval_tuple x0 -> - To.Outcometree.Oval_tuple - (List.map copy_out_value x0) - | From.Outcometree.Oval_variant (x0,x1) -> - To.Outcometree.Oval_variant - (x0, (copy_option copy_out_value x1)) - -and copy_float : float -> float = fun x -> x - -and copy_out_ident : - From.Outcometree.out_ident -> To.Outcometree.out_ident = + (fun x -> + let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1))) + x0) + | Ast_407.Outcometree.Oval_string (x0, x1, x2) -> + Ast_408.Outcometree.Oval_string (x0, x1, (copy_out_string x2)) + | Ast_407.Outcometree.Oval_stuff x0 -> Ast_408.Outcometree.Oval_stuff x0 + | Ast_407.Outcometree.Oval_tuple x0 -> + Ast_408.Outcometree.Oval_tuple (List.map copy_out_value x0) + | Ast_407.Outcometree.Oval_variant (x0, x1) -> + Ast_408.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1)) +and copy_out_string : + Ast_407.Outcometree.out_string -> Ast_408.Outcometree.out_string = function - | From.Outcometree.Oide_apply (x0,x1) -> - To.Outcometree.Oide_apply - ((copy_out_ident x0), - (copy_out_ident x1)) - | From.Outcometree.Oide_dot (x0,x1) -> - To.Outcometree.Oide_dot - ((copy_out_ident x0), x1) - | From.Outcometree.Oide_ident x0 -> + | Ast_407.Outcometree.Ostr_string -> Ast_408.Outcometree.Ostr_string + | Ast_407.Outcometree.Ostr_bytes -> Ast_408.Outcometree.Ostr_bytes +and copy_out_ident : + Ast_407.Outcometree.out_ident -> Ast_408.Outcometree.out_ident = + function + | Ast_407.Outcometree.Oide_apply (x0, x1) -> + Ast_408.Outcometree.Oide_apply + ((copy_out_ident x0), (copy_out_ident x1)) + | Ast_407.Outcometree.Oide_dot (x0, x1) -> + Ast_408.Outcometree.Oide_dot ((copy_out_ident x0), x1) + | Ast_407.Outcometree.Oide_ident x0 -> To.Outcometree.Oide_ident ({ To.Outcometree.printed_name = x0; }) - -let copy_out_type_extension : - From.Outcometree.out_type_extension -> To.Outcometree.out_type_extension = - fun - { From.Outcometree.otyext_name = otyext_name; - From.Outcometree.otyext_params = otyext_params; - From.Outcometree.otyext_constructors = otyext_constructors; - From.Outcometree.otyext_private = otyext_private } - -> - { - To.Outcometree.otyext_name = otyext_name; - To.Outcometree.otyext_params = - (List.map (fun x -> x) otyext_params); - To.Outcometree.otyext_constructors = - (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) - otyext_constructors); - To.Outcometree.otyext_private = - (copy_private_flag otyext_private) - } diff --git a/src/vendored-omp/src/migrate_parsetree_408_407.ml b/src/vendored-omp/src/migrate_parsetree_408_407.ml index 050d412e1..44e99a233 100644 --- a/src/vendored-omp/src/migrate_parsetree_408_407.ml +++ b/src/vendored-omp/src/migrate_parsetree_408_407.ml @@ -15,121 +15,3 @@ include Migrate_parsetree_408_407_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - (*$*) - (* The following ones were introduced in 4.08. *) - binding_op = _; - module_substitution = _; - open_declaration = _; - type_exception = _; - } as mapper) -> - let module R = Migrate_parsetree_407_408_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_408_407_migrate.ml b/src/vendored-omp/src/migrate_parsetree_408_407_migrate.ml index a9952e4a9..46b0a744a 100644 --- a/src/vendored-omp/src/migrate_parsetree_408_407_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_408_407_migrate.ml @@ -1,1707 +1,245 @@ -module From = Ast_408 -module To = Ast_407 - +open Stdlib0 module Def = Migrate_parsetree_def let migration_error location feature = raise (Def.Migration_error (feature, location)) -let rec copy_toplevel_phrase : - From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase = - function - | From.Parsetree.Ptop_def x0 -> - To.Parsetree.Ptop_def (copy_structure x0) - | From.Parsetree.Ptop_dir - { From.Parsetree.pdir_name; - From.Parsetree.pdir_arg; - From.Parsetree.pdir_loc = _; } -> - To.Parsetree.Ptop_dir - (pdir_name.Location.txt, - (match pdir_arg with - | None -> To.Parsetree.Pdir_none - | Some arg -> copy_directive_argument arg)) - -and copy_directive_argument : - From.Parsetree.directive_argument -> - To.Parsetree.directive_argument - = - fun - { From.Parsetree.pdira_desc = pdira_desc; - From.Parsetree.pdira_loc = _pdira_loc } - -> - (copy_directive_argument_desc pdira_desc) - -and copy_directive_argument_desc : - From.Parsetree.directive_argument_desc -> - To.Parsetree.directive_argument - = - function - | From.Parsetree.Pdir_string x0 -> To.Parsetree.Pdir_string x0 - | From.Parsetree.Pdir_int (x0,x1) -> - To.Parsetree.Pdir_int (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pdir_ident x0 -> - To.Parsetree.Pdir_ident (copy_longident x0) - | From.Parsetree.Pdir_bool x0 -> - To.Parsetree.Pdir_bool (copy_bool x0) - -and copy_expression : - From.Parsetree.expression -> To.Parsetree.expression = - fun - { From.Parsetree.pexp_desc = pexp_desc; - From.Parsetree.pexp_loc = pexp_loc; - From.Parsetree.pexp_loc_stack = _; - From.Parsetree.pexp_attributes = pexp_attributes } - -> - { - To.Parsetree.pexp_desc = - (copy_expression_desc pexp_desc); - To.Parsetree.pexp_loc = (copy_location pexp_loc); - To.Parsetree.pexp_attributes = - (copy_attributes pexp_attributes) - } - -and copy_expression_desc : - From.Parsetree.expression_desc -> To.Parsetree.expression_desc = - function - | From.Parsetree.Pexp_ident x0 -> - To.Parsetree.Pexp_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_constant x0 -> - To.Parsetree.Pexp_constant (copy_constant x0) - | From.Parsetree.Pexp_let (x0,x1,x2) -> - To.Parsetree.Pexp_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_expression x2)) - | From.Parsetree.Pexp_function x0 -> - To.Parsetree.Pexp_function - (List.map copy_case x0) - | From.Parsetree.Pexp_fun (x0,x1,x2,x3) -> - To.Parsetree.Pexp_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_expression x3)) - | From.Parsetree.Pexp_apply (x0,x1) -> - To.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pexp_match (x0,x1) -> - To.Parsetree.Pexp_match - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_try (x0,x1) -> - To.Parsetree.Pexp_try - ((copy_expression x0), - (List.map copy_case x1)) - | From.Parsetree.Pexp_tuple x0 -> - To.Parsetree.Pexp_tuple - (List.map copy_expression x0) - | From.Parsetree.Pexp_construct (x0,x1) -> - To.Parsetree.Pexp_construct - ((copy_loc copy_longident x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_variant (x0,x1) -> - To.Parsetree.Pexp_variant - ((copy_label x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_record (x0,x1) -> - To.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_expression x1))) x0), - (copy_option copy_expression x1)) - | From.Parsetree.Pexp_field (x0,x1) -> - To.Parsetree.Pexp_field - ((copy_expression x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pexp_setfield (x0,x1,x2) -> - To.Parsetree.Pexp_setfield - ((copy_expression x0), - (copy_loc copy_longident x1), - (copy_expression x2)) - | From.Parsetree.Pexp_array x0 -> - To.Parsetree.Pexp_array - (List.map copy_expression x0) - | From.Parsetree.Pexp_ifthenelse (x0,x1,x2) -> - To.Parsetree.Pexp_ifthenelse - ((copy_expression x0), - (copy_expression x1), - (copy_option copy_expression x2)) - | From.Parsetree.Pexp_sequence (x0,x1) -> - To.Parsetree.Pexp_sequence - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_while (x0,x1) -> - To.Parsetree.Pexp_while - ((copy_expression x0), - (copy_expression x1)) - | From.Parsetree.Pexp_for (x0,x1,x2,x3,x4) -> - To.Parsetree.Pexp_for - ((copy_pattern x0), - (copy_expression x1), - (copy_expression x2), - (copy_direction_flag x3), - (copy_expression x4)) - | From.Parsetree.Pexp_constraint (x0,x1) -> - To.Parsetree.Pexp_constraint - ((copy_expression x0), - (copy_core_type x1)) - | From.Parsetree.Pexp_coerce (x0,x1,x2) -> - To.Parsetree.Pexp_coerce - ((copy_expression x0), - (copy_option copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Pexp_send (x0,x1) -> - To.Parsetree.Pexp_send - ((copy_expression x0), - (copy_loc copy_label x1)) - | From.Parsetree.Pexp_new x0 -> - To.Parsetree.Pexp_new - (copy_loc copy_longident x0) - | From.Parsetree.Pexp_setinstvar (x0,x1) -> - To.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), - (copy_expression x1)) - | From.Parsetree.Pexp_override x0 -> - To.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_label x0), - (copy_expression x1))) x0) - | From.Parsetree.Pexp_letmodule (x0,x1,x2) -> - To.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> x) x0), - (copy_module_expr x1), - (copy_expression x2)) - | From.Parsetree.Pexp_letexception (x0,x1) -> - To.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), - (copy_expression x1)) - | From.Parsetree.Pexp_assert x0 -> - To.Parsetree.Pexp_assert (copy_expression x0) - | From.Parsetree.Pexp_lazy x0 -> - To.Parsetree.Pexp_lazy (copy_expression x0) - | From.Parsetree.Pexp_poly (x0,x1) -> - To.Parsetree.Pexp_poly - ((copy_expression x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pexp_object x0 -> - To.Parsetree.Pexp_object - (copy_class_structure x0) - | From.Parsetree.Pexp_newtype (x0,x1) -> - To.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), - (copy_expression x1)) - | From.Parsetree.Pexp_pack x0 -> - To.Parsetree.Pexp_pack (copy_module_expr x0) - | From.Parsetree.Pexp_open (x0,x1) -> - begin match x0.From.Parsetree.popen_expr.From.Parsetree.pmod_desc with - | Pmod_ident lid -> - To.Parsetree.Pexp_open - (copy_override_flag x0.From.Parsetree.popen_override, - (copy_loc copy_longident lid), - (copy_expression x1)) - | Pmod_structure _ | Pmod_functor _ | Pmod_apply _ - | Pmod_constraint _ | Pmod_unpack _ | Pmod_extension _ -> - migration_error x0.From.Parsetree.popen_loc Def.Pexp_open - end - | From.Parsetree.Pexp_letop { let_; ands = _; body = _; } -> - migration_error let_.pbop_op.loc Def.Pexp_letop - | From.Parsetree.Pexp_extension x0 -> - To.Parsetree.Pexp_extension (copy_extension x0) - | From.Parsetree.Pexp_unreachable -> To.Parsetree.Pexp_unreachable - -and copy_direction_flag : - From.Asttypes.direction_flag -> To.Asttypes.direction_flag = - function - | From.Asttypes.Upto -> To.Asttypes.Upto - | From.Asttypes.Downto -> To.Asttypes.Downto - -and copy_case : - From.Parsetree.case -> To.Parsetree.case = - fun - { From.Parsetree.pc_lhs = pc_lhs; - From.Parsetree.pc_guard = pc_guard; - From.Parsetree.pc_rhs = pc_rhs } - -> - { - To.Parsetree.pc_lhs = (copy_pattern pc_lhs); - To.Parsetree.pc_guard = - (copy_option copy_expression pc_guard); - To.Parsetree.pc_rhs = (copy_expression pc_rhs) - } - -and copy_value_binding : - From.Parsetree.value_binding -> To.Parsetree.value_binding = - fun - { From.Parsetree.pvb_pat = pvb_pat; - From.Parsetree.pvb_expr = pvb_expr; - From.Parsetree.pvb_attributes = pvb_attributes; - From.Parsetree.pvb_loc = pvb_loc } - -> - { - To.Parsetree.pvb_pat = (copy_pattern pvb_pat); - To.Parsetree.pvb_expr = - (copy_expression pvb_expr); - To.Parsetree.pvb_attributes = - (copy_attributes pvb_attributes); - To.Parsetree.pvb_loc = (copy_location pvb_loc) - } - -and copy_pattern : - From.Parsetree.pattern -> To.Parsetree.pattern = - fun - { From.Parsetree.ppat_desc = ppat_desc; - From.Parsetree.ppat_loc = ppat_loc; - From.Parsetree.ppat_loc_stack = _; - From.Parsetree.ppat_attributes = ppat_attributes } - -> - { - To.Parsetree.ppat_desc = - (copy_pattern_desc ppat_desc); - To.Parsetree.ppat_loc = (copy_location ppat_loc); - To.Parsetree.ppat_attributes = - (copy_attributes ppat_attributes) - } - -and copy_pattern_desc : - From.Parsetree.pattern_desc -> To.Parsetree.pattern_desc = - function - | From.Parsetree.Ppat_any -> To.Parsetree.Ppat_any - | From.Parsetree.Ppat_var x0 -> - To.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_alias (x0,x1) -> - To.Parsetree.Ppat_alias - ((copy_pattern x0), - (copy_loc (fun x -> x) x1)) - | From.Parsetree.Ppat_constant x0 -> - To.Parsetree.Ppat_constant (copy_constant x0) - | From.Parsetree.Ppat_interval (x0,x1) -> - To.Parsetree.Ppat_interval - ((copy_constant x0), - (copy_constant x1)) - | From.Parsetree.Ppat_tuple x0 -> - To.Parsetree.Ppat_tuple - (List.map copy_pattern x0) - | From.Parsetree.Ppat_construct (x0,x1) -> - To.Parsetree.Ppat_construct - ((copy_loc copy_longident x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_variant (x0,x1) -> - To.Parsetree.Ppat_variant - ((copy_label x0), - (copy_option copy_pattern x1)) - | From.Parsetree.Ppat_record (x0,x1) -> - To.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | From.Parsetree.Ppat_array x0 -> - To.Parsetree.Ppat_array - (List.map copy_pattern x0) - | From.Parsetree.Ppat_or (x0,x1) -> - To.Parsetree.Ppat_or - ((copy_pattern x0), - (copy_pattern x1)) - | From.Parsetree.Ppat_constraint (x0,x1) -> - To.Parsetree.Ppat_constraint - ((copy_pattern x0), - (copy_core_type x1)) - | From.Parsetree.Ppat_type x0 -> - To.Parsetree.Ppat_type - (copy_loc copy_longident x0) - | From.Parsetree.Ppat_lazy x0 -> - To.Parsetree.Ppat_lazy (copy_pattern x0) - | From.Parsetree.Ppat_unpack x0 -> - To.Parsetree.Ppat_unpack - (copy_loc (fun x -> x) x0) - | From.Parsetree.Ppat_exception x0 -> - To.Parsetree.Ppat_exception (copy_pattern x0) - | From.Parsetree.Ppat_extension x0 -> - To.Parsetree.Ppat_extension (copy_extension x0) - | From.Parsetree.Ppat_open (x0,x1) -> - To.Parsetree.Ppat_open - ((copy_loc copy_longident x0), - (copy_pattern x1)) - -and copy_core_type : - From.Parsetree.core_type -> To.Parsetree.core_type = - fun - { From.Parsetree.ptyp_desc = ptyp_desc; - From.Parsetree.ptyp_loc = ptyp_loc; - From.Parsetree.ptyp_loc_stack = _; - From.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - To.Parsetree.ptyp_desc = - (copy_core_type_desc ptyp_desc); - To.Parsetree.ptyp_loc = (copy_location ptyp_loc); - To.Parsetree.ptyp_attributes = - (copy_attributes ptyp_attributes) - } - -and copy_core_type_desc : - From.Parsetree.core_type_desc -> To.Parsetree.core_type_desc = - function - | From.Parsetree.Ptyp_any -> To.Parsetree.Ptyp_any - | From.Parsetree.Ptyp_var x0 -> To.Parsetree.Ptyp_var x0 - | From.Parsetree.Ptyp_arrow (x0,x1,x2) -> - To.Parsetree.Ptyp_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_core_type x2)) - | From.Parsetree.Ptyp_tuple x0 -> - To.Parsetree.Ptyp_tuple - (List.map copy_core_type x0) - | From.Parsetree.Ptyp_constr (x0,x1) -> - To.Parsetree.Ptyp_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_object (x0,x1) -> - To.Parsetree.Ptyp_object - ((List.map copy_object_field x0), - (copy_closed_flag x1)) - | From.Parsetree.Ptyp_class (x0,x1) -> - To.Parsetree.Ptyp_class - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Ptyp_alias (x0,x1) -> - To.Parsetree.Ptyp_alias - ((copy_core_type x0), x1) - | From.Parsetree.Ptyp_variant (x0,x1,x2) -> - To.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), - (copy_closed_flag x1), - (copy_option (fun x -> List.map copy_label x) x2)) - | From.Parsetree.Ptyp_poly (x0,x1) -> - To.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | From.Parsetree.Ptyp_package x0 -> - To.Parsetree.Ptyp_package (copy_package_type x0) - | From.Parsetree.Ptyp_extension x0 -> - To.Parsetree.Ptyp_extension (copy_extension x0) - -and copy_package_type : - From.Parsetree.package_type -> To.Parsetree.package_type = - fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_loc copy_longident x0), - (copy_core_type x1))) x1)) - -and copy_row_field : - From.Parsetree.row_field -> To.Parsetree.row_field = - fun - { From.Parsetree.prf_desc = prf_desc; - From.Parsetree.prf_loc = _; - From.Parsetree.prf_attributes = prf_attributes } - -> - match prf_desc with - | From.Parsetree.Rtag (x0, x1, x2) -> - To.Parsetree.Rtag ((copy_loc copy_label x0), - (copy_attributes prf_attributes), - (copy_bool x1), - (List.map copy_core_type x2)) - | From.Parsetree.Rinherit x0 -> - To.Parsetree.Rinherit (copy_core_type x0) - -and copy_object_field : - From.Parsetree.object_field -> To.Parsetree.object_field = - fun - { From.Parsetree.pof_desc = pof_desc; - From.Parsetree.pof_loc = _; - From.Parsetree.pof_attributes = pof_attributes } - -> - match pof_desc with - | From.Parsetree.Otag (x0, x1) -> - To.Parsetree.Otag ((copy_loc copy_label x0), - (copy_attributes pof_attributes), - (copy_core_type x1)) - | From.Parsetree.Oinherit x0 -> - To.Parsetree.Oinherit (copy_core_type x0) - -and copy_attributes : - From.Parsetree.attributes -> To.Parsetree.attributes = - fun x -> List.map copy_attribute x - -and copy_attribute : - From.Parsetree.attribute -> To.Parsetree.attribute = - fun - { From.Parsetree.attr_name = attr_name; - From.Parsetree.attr_payload = attr_payload; - From.Parsetree.attr_loc = _ } - -> - ((copy_loc (fun x -> x) attr_name), - (copy_payload attr_payload)) - -and copy_payload : - From.Parsetree.payload -> To.Parsetree.payload = - function - | From.Parsetree.PStr x0 -> - To.Parsetree.PStr (copy_structure x0) - | From.Parsetree.PSig x0 -> - To.Parsetree.PSig (copy_signature x0) - | From.Parsetree.PTyp x0 -> - To.Parsetree.PTyp (copy_core_type x0) - | From.Parsetree.PPat (x0,x1) -> - To.Parsetree.PPat - ((copy_pattern x0), - (copy_option copy_expression x1)) - -and copy_structure : - From.Parsetree.structure -> To.Parsetree.structure = - fun x -> List.map copy_structure_item x - -and copy_structure_item : - From.Parsetree.structure_item -> To.Parsetree.structure_item = - fun - { From.Parsetree.pstr_desc = pstr_desc; - From.Parsetree.pstr_loc = pstr_loc } - -> - { - To.Parsetree.pstr_desc = - (copy_structure_item_desc pstr_desc); - To.Parsetree.pstr_loc = (copy_location pstr_loc) - } - -and copy_structure_item_desc : - From.Parsetree.structure_item_desc -> - To.Parsetree.structure_item_desc - = - function - | From.Parsetree.Pstr_eval (x0,x1) -> - To.Parsetree.Pstr_eval - ((copy_expression x0), - (copy_attributes x1)) - | From.Parsetree.Pstr_value (x0,x1) -> - To.Parsetree.Pstr_value - ((copy_rec_flag x0), - (List.map copy_value_binding x1)) - | From.Parsetree.Pstr_primitive x0 -> - To.Parsetree.Pstr_primitive - (copy_value_description x0) - | From.Parsetree.Pstr_type (x0,x1) -> - To.Parsetree.Pstr_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Pstr_typext x0 -> - To.Parsetree.Pstr_typext - (copy_type_extension x0) - | From.Parsetree.Pstr_exception x0 -> - To.Parsetree.Pstr_exception - (let e = copy_extension_constructor - x0.From.Parsetree.ptyexn_constructor in - { e with pext_attributes = e.pext_attributes @ (copy_attributes x0.ptyexn_attributes) } - ) - | From.Parsetree.Pstr_module x0 -> - To.Parsetree.Pstr_module - (copy_module_binding x0) - | From.Parsetree.Pstr_recmodule x0 -> - To.Parsetree.Pstr_recmodule - (List.map copy_module_binding x0) - | From.Parsetree.Pstr_modtype x0 -> - To.Parsetree.Pstr_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Pstr_open x0 -> - begin match x0.From.Parsetree.popen_expr.From.Parsetree.pmod_desc with - | Pmod_ident lid -> - To.Parsetree.Pstr_open - { To.Parsetree.popen_lid = (copy_loc copy_longident lid); - To.Parsetree.popen_override = (copy_override_flag x0.From.Parsetree.popen_override); - To.Parsetree.popen_loc = (copy_location x0.From.Parsetree.popen_loc); - To.Parsetree.popen_attributes = (copy_attributes x0.From.Parsetree.popen_attributes); } - | Pmod_structure _ | Pmod_functor _ | Pmod_apply _ - | Pmod_constraint _ | Pmod_unpack _ | Pmod_extension _ -> - migration_error x0.From.Parsetree.popen_loc Def.Pexp_open - end - | From.Parsetree.Pstr_class x0 -> - To.Parsetree.Pstr_class - (List.map copy_class_declaration x0) - | From.Parsetree.Pstr_class_type x0 -> - To.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Pstr_include x0 -> - To.Parsetree.Pstr_include - (copy_include_declaration x0) - | From.Parsetree.Pstr_attribute x0 -> - To.Parsetree.Pstr_attribute (copy_attribute x0) - | From.Parsetree.Pstr_extension (x0,x1) -> - To.Parsetree.Pstr_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_include_declaration : - From.Parsetree.include_declaration -> - To.Parsetree.include_declaration - = - fun x -> - copy_include_infos copy_module_expr x - -and copy_class_declaration : - From.Parsetree.class_declaration -> To.Parsetree.class_declaration - = - fun x -> - copy_class_infos copy_class_expr x - -and copy_class_expr : - From.Parsetree.class_expr -> To.Parsetree.class_expr = - fun - { From.Parsetree.pcl_desc = pcl_desc; - From.Parsetree.pcl_loc = pcl_loc; - From.Parsetree.pcl_attributes = pcl_attributes } - -> - { - To.Parsetree.pcl_desc = - (copy_class_expr_desc pcl_desc); - To.Parsetree.pcl_loc = (copy_location pcl_loc); - To.Parsetree.pcl_attributes = - (copy_attributes pcl_attributes) - } - -and copy_class_expr_desc : - From.Parsetree.class_expr_desc -> To.Parsetree.class_expr_desc = - function - | From.Parsetree.Pcl_constr (x0,x1) -> - To.Parsetree.Pcl_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcl_structure x0 -> - To.Parsetree.Pcl_structure - (copy_class_structure x0) - | From.Parsetree.Pcl_fun (x0,x1,x2,x3) -> - To.Parsetree.Pcl_fun - ((copy_arg_label x0), - (copy_option copy_expression x1), - (copy_pattern x2), - (copy_class_expr x3)) - | From.Parsetree.Pcl_apply (x0,x1) -> - To.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_arg_label x0), - (copy_expression x1))) x1)) - | From.Parsetree.Pcl_let (x0,x1,x2) -> - To.Parsetree.Pcl_let - ((copy_rec_flag x0), - (List.map copy_value_binding x1), - (copy_class_expr x2)) - | From.Parsetree.Pcl_constraint (x0,x1) -> - To.Parsetree.Pcl_constraint - ((copy_class_expr x0), - (copy_class_type x1)) - | From.Parsetree.Pcl_extension x0 -> - To.Parsetree.Pcl_extension (copy_extension x0) - | From.Parsetree.Pcl_open (x0,x1) -> - To.Parsetree.Pcl_open - ((copy_override_flag x0.From.Parsetree.popen_override), - (copy_loc copy_longident x0.From.Parsetree.popen_expr), - (copy_class_expr x1)) - -and copy_class_structure : - From.Parsetree.class_structure -> To.Parsetree.class_structure = - fun - { From.Parsetree.pcstr_self = pcstr_self; - From.Parsetree.pcstr_fields = pcstr_fields } - -> - { - To.Parsetree.pcstr_self = - (copy_pattern pcstr_self); - To.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } - -and copy_class_field : - From.Parsetree.class_field -> To.Parsetree.class_field = - fun - { From.Parsetree.pcf_desc = pcf_desc; - From.Parsetree.pcf_loc = pcf_loc; - From.Parsetree.pcf_attributes = pcf_attributes } - -> - { - To.Parsetree.pcf_desc = - (copy_class_field_desc pcf_desc); - To.Parsetree.pcf_loc = (copy_location pcf_loc); - To.Parsetree.pcf_attributes = - (copy_attributes pcf_attributes) - } - -and copy_class_field_desc : - From.Parsetree.class_field_desc -> To.Parsetree.class_field_desc = - function - | From.Parsetree.Pcf_inherit (x0,x1,x2) -> - To.Parsetree.Pcf_inherit - ((copy_override_flag x0), - (copy_class_expr x1), - (copy_option (fun x -> copy_loc (fun x -> x) x) - x2)) - | From.Parsetree.Pcf_val x0 -> - To.Parsetree.Pcf_val - (let (x0,x1,x2) = x0 in - ((copy_loc copy_label x0), - (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_method x0 -> - To.Parsetree.Pcf_method - (let (x0,x1,x2) = x0 in - ((copy_loc copy_label x0), - (copy_private_flag x1), - (copy_class_field_kind x2))) - | From.Parsetree.Pcf_constraint x0 -> - To.Parsetree.Pcf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pcf_initializer x0 -> - To.Parsetree.Pcf_initializer - (copy_expression x0) - | From.Parsetree.Pcf_attribute x0 -> - To.Parsetree.Pcf_attribute (copy_attribute x0) - | From.Parsetree.Pcf_extension x0 -> - To.Parsetree.Pcf_extension (copy_extension x0) - -and copy_class_field_kind : - From.Parsetree.class_field_kind -> To.Parsetree.class_field_kind = - function - | From.Parsetree.Cfk_virtual x0 -> - To.Parsetree.Cfk_virtual (copy_core_type x0) - | From.Parsetree.Cfk_concrete (x0,x1) -> - To.Parsetree.Cfk_concrete - ((copy_override_flag x0), - (copy_expression x1)) - -and copy_module_binding : - From.Parsetree.module_binding -> To.Parsetree.module_binding = - fun - { From.Parsetree.pmb_name = pmb_name; - From.Parsetree.pmb_expr = pmb_expr; - From.Parsetree.pmb_attributes = pmb_attributes; - From.Parsetree.pmb_loc = pmb_loc } - -> - { - To.Parsetree.pmb_name = - (copy_loc (fun x -> x) pmb_name); - To.Parsetree.pmb_expr = - (copy_module_expr pmb_expr); - To.Parsetree.pmb_attributes = - (copy_attributes pmb_attributes); - To.Parsetree.pmb_loc = (copy_location pmb_loc) - } - -and copy_module_expr : - From.Parsetree.module_expr -> To.Parsetree.module_expr = - fun - { From.Parsetree.pmod_desc = pmod_desc; - From.Parsetree.pmod_loc = pmod_loc; - From.Parsetree.pmod_attributes = pmod_attributes } - -> - { - To.Parsetree.pmod_desc = - (copy_module_expr_desc pmod_desc); - To.Parsetree.pmod_loc = (copy_location pmod_loc); - To.Parsetree.pmod_attributes = - (copy_attributes pmod_attributes) - } - -and copy_module_expr_desc : - From.Parsetree.module_expr_desc -> To.Parsetree.module_expr_desc = - function - | From.Parsetree.Pmod_ident x0 -> - To.Parsetree.Pmod_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmod_structure x0 -> - To.Parsetree.Pmod_structure (copy_structure x0) - | From.Parsetree.Pmod_functor (x0,x1,x2) -> - To.Parsetree.Pmod_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_expr x2)) - | From.Parsetree.Pmod_apply (x0,x1) -> - To.Parsetree.Pmod_apply - ((copy_module_expr x0), - (copy_module_expr x1)) - | From.Parsetree.Pmod_constraint (x0,x1) -> - To.Parsetree.Pmod_constraint - ((copy_module_expr x0), - (copy_module_type x1)) - | From.Parsetree.Pmod_unpack x0 -> - To.Parsetree.Pmod_unpack (copy_expression x0) - | From.Parsetree.Pmod_extension x0 -> - To.Parsetree.Pmod_extension (copy_extension x0) - -and copy_module_type : - From.Parsetree.module_type -> To.Parsetree.module_type = - fun - { From.Parsetree.pmty_desc = pmty_desc; - From.Parsetree.pmty_loc = pmty_loc; - From.Parsetree.pmty_attributes = pmty_attributes } - -> - { - To.Parsetree.pmty_desc = - (copy_module_type_desc pmty_desc); - To.Parsetree.pmty_loc = (copy_location pmty_loc); - To.Parsetree.pmty_attributes = - (copy_attributes pmty_attributes) - } - -and copy_module_type_desc : - From.Parsetree.module_type_desc -> To.Parsetree.module_type_desc = - function - | From.Parsetree.Pmty_ident x0 -> - To.Parsetree.Pmty_ident - (copy_loc copy_longident x0) - | From.Parsetree.Pmty_signature x0 -> - To.Parsetree.Pmty_signature (copy_signature x0) - | From.Parsetree.Pmty_functor (x0,x1,x2) -> - To.Parsetree.Pmty_functor - ((copy_loc (fun x -> x) x0), - (copy_option copy_module_type x1), - (copy_module_type x2)) - | From.Parsetree.Pmty_with (x0,x1) -> - To.Parsetree.Pmty_with - ((copy_module_type x0), - (List.map copy_with_constraint x1)) - | From.Parsetree.Pmty_typeof x0 -> - To.Parsetree.Pmty_typeof (copy_module_expr x0) - | From.Parsetree.Pmty_extension x0 -> - To.Parsetree.Pmty_extension (copy_extension x0) - | From.Parsetree.Pmty_alias x0 -> - To.Parsetree.Pmty_alias - (copy_loc copy_longident x0) - -and copy_with_constraint : - From.Parsetree.with_constraint -> To.Parsetree.with_constraint = - function - | From.Parsetree.Pwith_type (x0,x1) -> - To.Parsetree.Pwith_type - ((copy_loc copy_longident x0), - (copy_type_declaration x1)) - | From.Parsetree.Pwith_module (x0,x1) -> - To.Parsetree.Pwith_module - ((copy_loc copy_longident x0), - (copy_loc copy_longident x1)) - | From.Parsetree.Pwith_typesubst (x0,x1) -> - To.Parsetree.Pwith_typesubst - ((copy_loc copy_longident x0), - (copy_type_declaration x1)) - | From.Parsetree.Pwith_modsubst (x0,x1) -> - To.Parsetree.Pwith_modsubst - ((copy_loc copy_longident x0), - (copy_loc copy_longident x1)) - -and copy_signature : - From.Parsetree.signature -> To.Parsetree.signature = - fun x -> List.map copy_signature_item x - -and copy_signature_item : - From.Parsetree.signature_item -> To.Parsetree.signature_item = - fun - { From.Parsetree.psig_desc = psig_desc; - From.Parsetree.psig_loc = psig_loc } - -> - { - To.Parsetree.psig_desc = - (copy_signature_item_desc psig_desc); - To.Parsetree.psig_loc = (copy_location psig_loc) - } - -and copy_signature_item_desc : - From.Parsetree.signature_item_desc -> - To.Parsetree.signature_item_desc - = - function - | From.Parsetree.Psig_value x0 -> - To.Parsetree.Psig_value - (copy_value_description x0) - | From.Parsetree.Psig_type (x0,x1) -> - To.Parsetree.Psig_type - ((copy_rec_flag x0), - (List.map copy_type_declaration x1)) - | From.Parsetree.Psig_typesubst x0 -> - let x0_loc = - match x0 with - | [] -> Location.none - | { From.Parsetree.ptype_loc; _ } :: _ -> ptype_loc in - migration_error x0_loc Def.Psig_typesubst - | From.Parsetree.Psig_typext x0 -> - To.Parsetree.Psig_typext - (copy_type_extension x0) - | From.Parsetree.Psig_exception x0 -> - To.Parsetree.Psig_exception - (let e = copy_extension_constructor - x0.From.Parsetree.ptyexn_constructor in - {e with pext_attributes = e.pext_attributes @ (copy_attributes x0.ptyexn_attributes) }) - | From.Parsetree.Psig_module x0 -> - To.Parsetree.Psig_module - (copy_module_declaration x0) - | From.Parsetree.Psig_modsubst x0 -> - migration_error x0.pms_loc Def.Psig_modsubst - | From.Parsetree.Psig_recmodule x0 -> - To.Parsetree.Psig_recmodule - (List.map copy_module_declaration x0) - | From.Parsetree.Psig_modtype x0 -> - To.Parsetree.Psig_modtype - (copy_module_type_declaration x0) - | From.Parsetree.Psig_open x0 -> - To.Parsetree.Psig_open - (copy_open_description x0) - | From.Parsetree.Psig_include x0 -> - To.Parsetree.Psig_include - (copy_include_description x0) - | From.Parsetree.Psig_class x0 -> - To.Parsetree.Psig_class - (List.map copy_class_description x0) - | From.Parsetree.Psig_class_type x0 -> - To.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | From.Parsetree.Psig_attribute x0 -> - To.Parsetree.Psig_attribute (copy_attribute x0) - | From.Parsetree.Psig_extension (x0,x1) -> - To.Parsetree.Psig_extension - ((copy_extension x0), - (copy_attributes x1)) - -and copy_class_type_declaration : - From.Parsetree.class_type_declaration -> - To.Parsetree.class_type_declaration - = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_description : - From.Parsetree.class_description -> To.Parsetree.class_description - = - fun x -> - copy_class_infos copy_class_type x - -and copy_class_type : - From.Parsetree.class_type -> To.Parsetree.class_type = - fun - { From.Parsetree.pcty_desc = pcty_desc; - From.Parsetree.pcty_loc = pcty_loc; - From.Parsetree.pcty_attributes = pcty_attributes } - -> - { - To.Parsetree.pcty_desc = - (copy_class_type_desc pcty_desc); - To.Parsetree.pcty_loc = (copy_location pcty_loc); - To.Parsetree.pcty_attributes = - (copy_attributes pcty_attributes) - } - -and copy_class_type_desc : - From.Parsetree.class_type_desc -> To.Parsetree.class_type_desc = - function - | From.Parsetree.Pcty_constr (x0,x1) -> - To.Parsetree.Pcty_constr - ((copy_loc copy_longident x0), - (List.map copy_core_type x1)) - | From.Parsetree.Pcty_signature x0 -> - To.Parsetree.Pcty_signature - (copy_class_signature x0) - | From.Parsetree.Pcty_arrow (x0,x1,x2) -> - To.Parsetree.Pcty_arrow - ((copy_arg_label x0), - (copy_core_type x1), - (copy_class_type x2)) - | From.Parsetree.Pcty_extension x0 -> - To.Parsetree.Pcty_extension (copy_extension x0) - | From.Parsetree.Pcty_open (x0,x1) -> - To.Parsetree.Pcty_open - ((copy_override_flag x0.From.Parsetree.popen_override), - (copy_loc copy_longident x0.From.Parsetree.popen_expr), - (copy_class_type x1)) - -and copy_class_signature : - From.Parsetree.class_signature -> To.Parsetree.class_signature = - fun - { From.Parsetree.pcsig_self = pcsig_self; - From.Parsetree.pcsig_fields = pcsig_fields } - -> - { - To.Parsetree.pcsig_self = - (copy_core_type pcsig_self); - To.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } - -and copy_class_type_field : - From.Parsetree.class_type_field -> To.Parsetree.class_type_field = - fun - { From.Parsetree.pctf_desc = pctf_desc; - From.Parsetree.pctf_loc = pctf_loc; - From.Parsetree.pctf_attributes = pctf_attributes } - -> - { - To.Parsetree.pctf_desc = - (copy_class_type_field_desc pctf_desc); - To.Parsetree.pctf_loc = (copy_location pctf_loc); - To.Parsetree.pctf_attributes = - (copy_attributes pctf_attributes) - } - -and copy_class_type_field_desc : - From.Parsetree.class_type_field_desc -> - To.Parsetree.class_type_field_desc - = - function - | From.Parsetree.Pctf_inherit x0 -> - To.Parsetree.Pctf_inherit (copy_class_type x0) - | From.Parsetree.Pctf_val x0 -> - To.Parsetree.Pctf_val - (let (x0,x1,x2,x3) = x0 in - ((copy_loc copy_label x0), - (copy_mutable_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_method x0 -> - To.Parsetree.Pctf_method - (let (x0,x1,x2,x3) = x0 in - ((copy_loc copy_label x0), - (copy_private_flag x1), - (copy_virtual_flag x2), - (copy_core_type x3))) - | From.Parsetree.Pctf_constraint x0 -> - To.Parsetree.Pctf_constraint - (let (x0,x1) = x0 in - ((copy_core_type x0), - (copy_core_type x1))) - | From.Parsetree.Pctf_attribute x0 -> - To.Parsetree.Pctf_attribute (copy_attribute x0) - | From.Parsetree.Pctf_extension x0 -> - To.Parsetree.Pctf_extension (copy_extension x0) - -and copy_extension : - From.Parsetree.extension -> To.Parsetree.extension = - fun x -> - let (x0,x1) = x in - let x1 = - match x0.txt with - | "ocaml.error" | "error" -> - begin match x1 with - | PStr (hd :: tl) -> From.Parsetree.PStr (hd :: hd :: tl) - | _ -> x1 - end - | _ -> x1 in - ((copy_loc (fun x -> x) x0), - (copy_payload x1)) - -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.class_infos -> 'g0 To.Parsetree.class_infos - = - fun f0 -> - fun - { From.Parsetree.pci_virt = pci_virt; - From.Parsetree.pci_params = pci_params; - From.Parsetree.pci_name = pci_name; - From.Parsetree.pci_expr = pci_expr; - From.Parsetree.pci_loc = pci_loc; - From.Parsetree.pci_attributes = pci_attributes } - -> - { - To.Parsetree.pci_virt = - (copy_virtual_flag pci_virt); - To.Parsetree.pci_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) pci_params); - To.Parsetree.pci_name = - (copy_loc (fun x -> x) pci_name); - To.Parsetree.pci_expr = (f0 pci_expr); - To.Parsetree.pci_loc = (copy_location pci_loc); - To.Parsetree.pci_attributes = - (copy_attributes pci_attributes) - } - -and copy_virtual_flag : - From.Asttypes.virtual_flag -> To.Asttypes.virtual_flag = - function - | From.Asttypes.Virtual -> To.Asttypes.Virtual - | From.Asttypes.Concrete -> To.Asttypes.Concrete - -and copy_include_description : - From.Parsetree.include_description -> - To.Parsetree.include_description - = - fun x -> - copy_include_infos copy_module_type x - -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 From.Parsetree.include_infos -> - 'g0 To.Parsetree.include_infos +module From = Ast_408 +module To = Ast_407 +let rec copy_out_type_extension : + Ast_408.Outcometree.out_type_extension -> + Ast_407.Outcometree.out_type_extension = - fun f0 -> - fun - { From.Parsetree.pincl_mod = pincl_mod; - From.Parsetree.pincl_loc = pincl_loc; - From.Parsetree.pincl_attributes = pincl_attributes } - -> - { - To.Parsetree.pincl_mod = (f0 pincl_mod); - To.Parsetree.pincl_loc = (copy_location pincl_loc); - To.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } - -and copy_open_description : - From.Parsetree.open_description -> To.Parsetree.open_description = fun - { From.Parsetree.popen_expr = popen_expr; - From.Parsetree.popen_override = popen_override; - From.Parsetree.popen_loc = popen_loc; - From.Parsetree.popen_attributes = popen_attributes } + { Ast_408.Outcometree.otyext_name = otyext_name; + Ast_408.Outcometree.otyext_params = otyext_params; + Ast_408.Outcometree.otyext_constructors = otyext_constructors; + Ast_408.Outcometree.otyext_private = otyext_private } -> - { To.Parsetree.popen_lid = (copy_loc copy_longident popen_expr); - To.Parsetree.popen_override = (copy_override_flag popen_override); - To.Parsetree.popen_loc = (copy_location popen_loc); - To.Parsetree.popen_attributes = (copy_attributes popen_attributes); } - -and copy_override_flag : - From.Asttypes.override_flag -> To.Asttypes.override_flag = - function - | From.Asttypes.Override -> To.Asttypes.Override - | From.Asttypes.Fresh -> To.Asttypes.Fresh - -and copy_module_type_declaration : - From.Parsetree.module_type_declaration -> - To.Parsetree.module_type_declaration - = - fun - { From.Parsetree.pmtd_name = pmtd_name; - From.Parsetree.pmtd_type = pmtd_type; - From.Parsetree.pmtd_attributes = pmtd_attributes; - From.Parsetree.pmtd_loc = pmtd_loc } - -> - { - To.Parsetree.pmtd_name = - (copy_loc (fun x -> x) pmtd_name); - To.Parsetree.pmtd_type = - (copy_option copy_module_type pmtd_type); - To.Parsetree.pmtd_attributes = - (copy_attributes pmtd_attributes); - To.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } - -and copy_module_declaration : - From.Parsetree.module_declaration -> - To.Parsetree.module_declaration - = - fun - { From.Parsetree.pmd_name = pmd_name; - From.Parsetree.pmd_type = pmd_type; - From.Parsetree.pmd_attributes = pmd_attributes; - From.Parsetree.pmd_loc = pmd_loc } - -> { - To.Parsetree.pmd_name = - (copy_loc (fun x -> x) pmd_name); - To.Parsetree.pmd_type = - (copy_module_type pmd_type); - To.Parsetree.pmd_attributes = - (copy_attributes pmd_attributes); - To.Parsetree.pmd_loc = (copy_location pmd_loc) - } - -(* and copy_type_exception : - From.Parsetree.type_exception -> To.Parsetree.type_exception = - fun - { From.Parsetree.ptyexn_constructor = ptyexn_constructor; - From.Parsetree.ptyexn_loc = ptyexn_loc; - From.Parsetree.ptyexn_attributes = ptyexn_attributes } - -> - { - To.Parsetree.ptyexn_constructor = - (copy_extension_constructor ptyexn_constructor); - To.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); - To.Parsetree.ptyexn_attributes = - (copy_attributes ptyexn_attributes) - }*) - -and copy_type_extension : - From.Parsetree.type_extension -> To.Parsetree.type_extension = - fun - { From.Parsetree.ptyext_path = ptyext_path; - From.Parsetree.ptyext_params = ptyext_params; - From.Parsetree.ptyext_constructors = ptyext_constructors; - From.Parsetree.ptyext_private = ptyext_private; - From.Parsetree.ptyext_loc = _; - From.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - To.Parsetree.ptyext_path = - (copy_loc copy_longident ptyext_path); - To.Parsetree.ptyext_params = + Ast_407.Outcometree.otyext_name = otyext_name; + Ast_407.Outcometree.otyext_params = + (List.map (fun x -> x) otyext_params); + Ast_407.Outcometree.otyext_constructors = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptyext_params); - To.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor - ptyext_constructors); - To.Parsetree.ptyext_private = - (copy_private_flag ptyext_private); - To.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } - -and copy_extension_constructor : - From.Parsetree.extension_constructor -> - To.Parsetree.extension_constructor - = - fun - { From.Parsetree.pext_name = pext_name; - From.Parsetree.pext_kind = pext_kind; - From.Parsetree.pext_loc = pext_loc; - From.Parsetree.pext_attributes = pext_attributes } - -> - { - To.Parsetree.pext_name = - (copy_loc (fun x -> x) pext_name); - To.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - To.Parsetree.pext_loc = (copy_location pext_loc); - To.Parsetree.pext_attributes = - (copy_attributes pext_attributes) - } - -and copy_extension_constructor_kind : - From.Parsetree.extension_constructor_kind -> - To.Parsetree.extension_constructor_kind - = - function - | From.Parsetree.Pext_decl (x0,x1) -> - To.Parsetree.Pext_decl - ((copy_constructor_arguments x0), - (copy_option copy_core_type x1)) - | From.Parsetree.Pext_rebind x0 -> - To.Parsetree.Pext_rebind - (copy_loc copy_longident x0) - -and copy_type_declaration : - From.Parsetree.type_declaration -> To.Parsetree.type_declaration = - fun - { From.Parsetree.ptype_name = ptype_name; - From.Parsetree.ptype_params = ptype_params; - From.Parsetree.ptype_cstrs = ptype_cstrs; - From.Parsetree.ptype_kind = ptype_kind; - From.Parsetree.ptype_private = ptype_private; - From.Parsetree.ptype_manifest = ptype_manifest; - From.Parsetree.ptype_attributes = ptype_attributes; - From.Parsetree.ptype_loc = ptype_loc } - -> - { - To.Parsetree.ptype_name = - (copy_loc (fun x -> x) ptype_name); - To.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0,x1) = x in - ((copy_core_type x0), - (copy_variance x1))) ptype_params); - To.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0,x1,x2) = x in - ((copy_core_type x0), - (copy_core_type x1), - (copy_location x2))) ptype_cstrs); - To.Parsetree.ptype_kind = - (copy_type_kind ptype_kind); - To.Parsetree.ptype_private = - (copy_private_flag ptype_private); - To.Parsetree.ptype_manifest = - (copy_option copy_core_type ptype_manifest); - To.Parsetree.ptype_attributes = - (copy_attributes ptype_attributes); - To.Parsetree.ptype_loc = (copy_location ptype_loc) - } - -and copy_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = - function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - -and copy_type_kind : - From.Parsetree.type_kind -> To.Parsetree.type_kind = - function - | From.Parsetree.Ptype_abstract -> To.Parsetree.Ptype_abstract - | From.Parsetree.Ptype_variant x0 -> - To.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | From.Parsetree.Ptype_record x0 -> - To.Parsetree.Ptype_record - (List.map copy_label_declaration x0) - | From.Parsetree.Ptype_open -> To.Parsetree.Ptype_open - -and copy_constructor_declaration : - From.Parsetree.constructor_declaration -> - To.Parsetree.constructor_declaration - = - fun - { From.Parsetree.pcd_name = pcd_name; - From.Parsetree.pcd_args = pcd_args; - From.Parsetree.pcd_res = pcd_res; - From.Parsetree.pcd_loc = pcd_loc; - From.Parsetree.pcd_attributes = pcd_attributes } - -> - { - To.Parsetree.pcd_name = - (copy_loc (fun x -> x) pcd_name); - To.Parsetree.pcd_args = - (copy_constructor_arguments pcd_args); - To.Parsetree.pcd_res = - (copy_option copy_core_type pcd_res); - To.Parsetree.pcd_loc = (copy_location pcd_loc); - To.Parsetree.pcd_attributes = - (copy_attributes pcd_attributes) - } - -and copy_constructor_arguments : - From.Parsetree.constructor_arguments -> - To.Parsetree.constructor_arguments - = - function - | From.Parsetree.Pcstr_tuple x0 -> - To.Parsetree.Pcstr_tuple - (List.map copy_core_type x0) - | From.Parsetree.Pcstr_record x0 -> - To.Parsetree.Pcstr_record - (List.map copy_label_declaration x0) - -and copy_label_declaration : - From.Parsetree.label_declaration -> To.Parsetree.label_declaration - = - fun - { From.Parsetree.pld_name = pld_name; - From.Parsetree.pld_mutable = pld_mutable; - From.Parsetree.pld_type = pld_type; - From.Parsetree.pld_loc = pld_loc; - From.Parsetree.pld_attributes = pld_attributes } - -> - { - To.Parsetree.pld_name = - (copy_loc (fun x -> x) pld_name); - To.Parsetree.pld_mutable = - (copy_mutable_flag pld_mutable); - To.Parsetree.pld_type = - (copy_core_type pld_type); - To.Parsetree.pld_loc = (copy_location pld_loc); - To.Parsetree.pld_attributes = - (copy_attributes pld_attributes) - } - -and copy_mutable_flag : - From.Asttypes.mutable_flag -> To.Asttypes.mutable_flag = - function - | From.Asttypes.Immutable -> To.Asttypes.Immutable - | From.Asttypes.Mutable -> To.Asttypes.Mutable - -and copy_variance : - From.Asttypes.variance -> To.Asttypes.variance = - function - | From.Asttypes.Covariant -> To.Asttypes.Covariant - | From.Asttypes.Contravariant -> To.Asttypes.Contravariant - | From.Asttypes.Invariant -> To.Asttypes.Invariant - -and copy_value_description : - From.Parsetree.value_description -> To.Parsetree.value_description - = - fun - { From.Parsetree.pval_name = pval_name; - From.Parsetree.pval_type = pval_type; - From.Parsetree.pval_prim = pval_prim; - From.Parsetree.pval_attributes = pval_attributes; - From.Parsetree.pval_loc = pval_loc } - -> - { - To.Parsetree.pval_name = - (copy_loc (fun x -> x) pval_name); - To.Parsetree.pval_type = - (copy_core_type pval_type); - To.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - To.Parsetree.pval_attributes = - (copy_attributes pval_attributes); - To.Parsetree.pval_loc = (copy_location pval_loc) - } - -and copy_arg_label : - From.Asttypes.arg_label -> To.Asttypes.arg_label = - function - | From.Asttypes.Nolabel -> To.Asttypes.Nolabel - | From.Asttypes.Labelled x0 -> To.Asttypes.Labelled x0 - | From.Asttypes.Optional x0 -> To.Asttypes.Optional x0 - -and copy_closed_flag : - From.Asttypes.closed_flag -> To.Asttypes.closed_flag = - function - | From.Asttypes.Closed -> To.Asttypes.Closed - | From.Asttypes.Open -> To.Asttypes.Open - -and copy_label : - From.Asttypes.label -> To.Asttypes.label = fun x -> x - -and copy_rec_flag : - From.Asttypes.rec_flag -> To.Asttypes.rec_flag = - function - | From.Asttypes.Nonrecursive -> To.Asttypes.Nonrecursive - | From.Asttypes.Recursive -> To.Asttypes.Recursive - -and copy_constant : - From.Parsetree.constant -> To.Parsetree.constant = - function - | From.Parsetree.Pconst_integer (x0,x1) -> - To.Parsetree.Pconst_integer (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_char x0 -> To.Parsetree.Pconst_char x0 - | From.Parsetree.Pconst_string (x0,x1) -> - To.Parsetree.Pconst_string (x0, (copy_option (fun x -> x) x1)) - | From.Parsetree.Pconst_float (x0,x1) -> - To.Parsetree.Pconst_float (x0, (copy_option (fun x -> x) x1)) - -and copy_option : 'f0 'g0 . ('f0 -> 'g0) -> 'f0 option -> 'g0 option = - fun f0 -> function | None -> None | Some x0 -> Some (f0 x0) - -and copy_longident : From.Longident.t -> To.Longident.t = - function - | From.Longident.Lident x0 -> To.Longident.Lident x0 - | From.Longident.Ldot (x0,x1) -> - To.Longident.Ldot ((copy_longident x0), x1) - | From.Longident.Lapply (x0,x1) -> - To.Longident.Lapply - ((copy_longident x0), (copy_longident x1)) - -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 From.Asttypes.loc -> 'g0 To.Asttypes.loc - = - fun f0 -> - fun { From.Asttypes.txt = txt; From.Asttypes.loc = loc } -> - { - To.Asttypes.txt = (f0 txt); - To.Asttypes.loc = (copy_location loc) - } - -and copy_location : From.Location.t -> To.Location.t = - fun - { From.Location.loc_start = loc_start; - From.Location.loc_end = loc_end; - From.Location.loc_ghost = loc_ghost } - -> - { - To.Location.loc_start = (copy_Lexing_position loc_start); - To.Location.loc_end = (copy_Lexing_position loc_end); - To.Location.loc_ghost = (copy_bool loc_ghost) - } - -and copy_bool : bool -> bool = function | false -> false | true -> true - -and copy_Lexing_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum + (fun x -> + let (x0, x1, x2) = x in + (x0, (List.map copy_out_type x1), + (Option.map copy_out_type x2))) otyext_constructors); + Ast_407.Outcometree.otyext_private = (copy_private_flag otyext_private) } - -let copy_cases x = List.map copy_case x -let copy_pat = copy_pattern -let copy_expr = copy_expression -let copy_typ = copy_core_type - -let rec copy_out_phrase : - From.Outcometree.out_phrase -> To.Outcometree.out_phrase = +and copy_out_phrase : + Ast_408.Outcometree.out_phrase -> Ast_407.Outcometree.out_phrase = function - | From.Outcometree.Ophr_eval (x0,x1) -> - To.Outcometree.Ophr_eval - ((copy_out_value x0), - (copy_out_type x1)) - | From.Outcometree.Ophr_signature x0 -> - To.Outcometree.Ophr_signature + | Ast_408.Outcometree.Ophr_eval (x0, x1) -> + Ast_407.Outcometree.Ophr_eval ((copy_out_value x0), (copy_out_type x1)) + | Ast_408.Outcometree.Ophr_signature x0 -> + Ast_407.Outcometree.Ophr_signature (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_sig_item x0), - (copy_option copy_out_value x1))) x0) - | From.Outcometree.Ophr_exception x0 -> - To.Outcometree.Ophr_exception - (let (x0,x1) = x0 in - ((copy_exn x0), (copy_out_value x1))) - -and copy_exn : exn -> exn = fun x -> x - + (fun x -> + let (x0, x1) = x in + ((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0) + | Ast_408.Outcometree.Ophr_exception x0 -> + Ast_407.Outcometree.Ophr_exception + (let (x0, x1) = x0 in (x0, (copy_out_value x1))) and copy_out_sig_item : - From.Outcometree.out_sig_item -> To.Outcometree.out_sig_item = + Ast_408.Outcometree.out_sig_item -> Ast_407.Outcometree.out_sig_item = function - | From.Outcometree.Osig_class (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class - ((copy_bool x0), x1, + | Ast_408.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> + Ast_407.Outcometree.Osig_class + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_class_type (x0,x1,x2,x3,x4) -> - To.Outcometree.Osig_class_type - ((copy_bool x0), x1, + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_408.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> + Ast_407.Outcometree.Osig_class_type + (x0, x1, (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) - x2), (copy_out_class_type x3), - (copy_out_rec_status x4)) - | From.Outcometree.Osig_typext (x0,x1) -> - To.Outcometree.Osig_typext - ((copy_out_extension_constructor x0), - (copy_out_ext_status x1)) - | From.Outcometree.Osig_modtype (x0,x1) -> - To.Outcometree.Osig_modtype - (x0, (copy_out_module_type x1)) - | From.Outcometree.Osig_module (x0,x1,x2) -> - To.Outcometree.Osig_module - (x0, (copy_out_module_type x1), - (copy_out_rec_status x2)) - | From.Outcometree.Osig_type (x0,x1) -> - To.Outcometree.Osig_type - ((copy_out_type_decl x0), - (copy_out_rec_status x1)) - | From.Outcometree.Osig_value x0 -> - To.Outcometree.Osig_value - (copy_out_val_decl x0) - | From.Outcometree.Osig_ellipsis -> To.Outcometree.Osig_ellipsis - + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) + | Ast_408.Outcometree.Osig_typext (x0, x1) -> + Ast_407.Outcometree.Osig_typext + ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) + | Ast_408.Outcometree.Osig_modtype (x0, x1) -> + Ast_407.Outcometree.Osig_modtype (x0, (copy_out_module_type x1)) + | Ast_408.Outcometree.Osig_module (x0, x1, x2) -> + Ast_407.Outcometree.Osig_module + (x0, (copy_out_module_type x1), (copy_out_rec_status x2)) + | Ast_408.Outcometree.Osig_type (x0, x1) -> + Ast_407.Outcometree.Osig_type + ((copy_out_type_decl x0), (copy_out_rec_status x1)) + | Ast_408.Outcometree.Osig_value x0 -> + Ast_407.Outcometree.Osig_value (copy_out_val_decl x0) + | Ast_408.Outcometree.Osig_ellipsis -> Ast_407.Outcometree.Osig_ellipsis and copy_out_val_decl : - From.Outcometree.out_val_decl -> To.Outcometree.out_val_decl = + Ast_408.Outcometree.out_val_decl -> Ast_407.Outcometree.out_val_decl = fun - { From.Outcometree.oval_name = oval_name; - From.Outcometree.oval_type = oval_type; - From.Outcometree.oval_prims = oval_prims; - From.Outcometree.oval_attributes = oval_attributes } - -> + { Ast_408.Outcometree.oval_name = oval_name; + Ast_408.Outcometree.oval_type = oval_type; + Ast_408.Outcometree.oval_prims = oval_prims; + Ast_408.Outcometree.oval_attributes = oval_attributes } + -> { - To.Outcometree.oval_name = oval_name; - To.Outcometree.oval_type = - (copy_out_type oval_type); - To.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); - To.Outcometree.oval_attributes = + Ast_407.Outcometree.oval_name = oval_name; + Ast_407.Outcometree.oval_type = (copy_out_type oval_type); + Ast_407.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); + Ast_407.Outcometree.oval_attributes = (List.map copy_out_attribute oval_attributes) } - and copy_out_type_decl : - From.Outcometree.out_type_decl -> To.Outcometree.out_type_decl = - fun - { From.Outcometree.otype_name = otype_name; - From.Outcometree.otype_params = otype_params; - From.Outcometree.otype_type = otype_type; - From.Outcometree.otype_private = otype_private; - From.Outcometree.otype_immediate = otype_immediate; - From.Outcometree.otype_unboxed = otype_unboxed; - From.Outcometree.otype_cstrs = otype_cstrs } - -> + Ast_408.Outcometree.out_type_decl -> Ast_407.Outcometree.out_type_decl = + fun + { Ast_408.Outcometree.otype_name = otype_name; + Ast_408.Outcometree.otype_params = otype_params; + Ast_408.Outcometree.otype_type = otype_type; + Ast_408.Outcometree.otype_private = otype_private; + Ast_408.Outcometree.otype_immediate = otype_immediate; + Ast_408.Outcometree.otype_unboxed = otype_unboxed; + Ast_408.Outcometree.otype_cstrs = otype_cstrs } + -> { - To.Outcometree.otype_name = otype_name; - To.Outcometree.otype_params = + Ast_407.Outcometree.otype_name = otype_name; + Ast_407.Outcometree.otype_params = (List.map - (fun x -> - let (x0,x1) = x in - (x0, (let (x0,x1) = x1 in ((copy_bool x0), (copy_bool x1))))) + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) otype_params); - To.Outcometree.otype_type = - (copy_out_type otype_type); - To.Outcometree.otype_private = - (copy_From_Asttypes_private_flag otype_private); - To.Outcometree.otype_immediate = (copy_bool otype_immediate); - To.Outcometree.otype_unboxed = (copy_bool otype_unboxed); - To.Outcometree.otype_cstrs = + Ast_407.Outcometree.otype_type = (copy_out_type otype_type); + Ast_407.Outcometree.otype_private = (copy_private_flag otype_private); + Ast_407.Outcometree.otype_immediate = otype_immediate; + Ast_407.Outcometree.otype_unboxed = otype_unboxed; + Ast_407.Outcometree.otype_cstrs = (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_type x0), - (copy_out_type x1))) otype_cstrs) + (fun x -> + let (x0, x1) = x in ((copy_out_type x0), (copy_out_type x1))) + otype_cstrs) } - and copy_out_module_type : - From.Outcometree.out_module_type -> To.Outcometree.out_module_type + Ast_408.Outcometree.out_module_type -> Ast_407.Outcometree.out_module_type = function - | From.Outcometree.Omty_abstract -> To.Outcometree.Omty_abstract - | From.Outcometree.Omty_functor (x0,x1,x2) -> - To.Outcometree.Omty_functor - (x0, (copy_option copy_out_module_type x1), - (copy_out_module_type x2)) - | From.Outcometree.Omty_ident x0 -> - To.Outcometree.Omty_ident (copy_out_ident x0) - | From.Outcometree.Omty_signature x0 -> - To.Outcometree.Omty_signature - (List.map copy_out_sig_item x0) - | From.Outcometree.Omty_alias x0 -> - To.Outcometree.Omty_alias (copy_out_ident x0) - + | Ast_408.Outcometree.Omty_abstract -> Ast_407.Outcometree.Omty_abstract + | Ast_408.Outcometree.Omty_functor (x0, x1, x2) -> + Ast_407.Outcometree.Omty_functor + (x0, (Option.map copy_out_module_type x1), (copy_out_module_type x2)) + | Ast_408.Outcometree.Omty_ident x0 -> + Ast_407.Outcometree.Omty_ident (copy_out_ident x0) + | Ast_408.Outcometree.Omty_signature x0 -> + Ast_407.Outcometree.Omty_signature (List.map copy_out_sig_item x0) + | Ast_408.Outcometree.Omty_alias x0 -> + Ast_407.Outcometree.Omty_alias (copy_out_ident x0) and copy_out_ext_status : - From.Outcometree.out_ext_status -> To.Outcometree.out_ext_status = + Ast_408.Outcometree.out_ext_status -> Ast_407.Outcometree.out_ext_status = function - | From.Outcometree.Oext_first -> To.Outcometree.Oext_first - | From.Outcometree.Oext_next -> To.Outcometree.Oext_next - | From.Outcometree.Oext_exception -> To.Outcometree.Oext_exception - + | Ast_408.Outcometree.Oext_first -> Ast_407.Outcometree.Oext_first + | Ast_408.Outcometree.Oext_next -> Ast_407.Outcometree.Oext_next + | Ast_408.Outcometree.Oext_exception -> Ast_407.Outcometree.Oext_exception and copy_out_extension_constructor : - From.Outcometree.out_extension_constructor -> - To.Outcometree.out_extension_constructor + Ast_408.Outcometree.out_extension_constructor -> + Ast_407.Outcometree.out_extension_constructor = fun - { From.Outcometree.oext_name = oext_name; - From.Outcometree.oext_type_name = oext_type_name; - From.Outcometree.oext_type_params = oext_type_params; - From.Outcometree.oext_args = oext_args; - From.Outcometree.oext_ret_type = oext_ret_type; - From.Outcometree.oext_private = oext_private } - -> + { Ast_408.Outcometree.oext_name = oext_name; + Ast_408.Outcometree.oext_type_name = oext_type_name; + Ast_408.Outcometree.oext_type_params = oext_type_params; + Ast_408.Outcometree.oext_args = oext_args; + Ast_408.Outcometree.oext_ret_type = oext_ret_type; + Ast_408.Outcometree.oext_private = oext_private } + -> { - To.Outcometree.oext_name = oext_name; - To.Outcometree.oext_type_name = oext_type_name; - To.Outcometree.oext_type_params = - (List.map (fun x -> x) oext_type_params); - To.Outcometree.oext_args = - (List.map copy_out_type oext_args); - To.Outcometree.oext_ret_type = - (copy_option copy_out_type oext_ret_type); - To.Outcometree.oext_private = - (copy_From_Asttypes_private_flag oext_private) + Ast_407.Outcometree.oext_name = oext_name; + Ast_407.Outcometree.oext_type_name = oext_type_name; + Ast_407.Outcometree.oext_type_params = + (List.map (fun x -> x) oext_type_params); + Ast_407.Outcometree.oext_args = (List.map copy_out_type oext_args); + Ast_407.Outcometree.oext_ret_type = + (Option.map copy_out_type oext_ret_type); + Ast_407.Outcometree.oext_private = (copy_private_flag oext_private) } - -and copy_From_Asttypes_private_flag : - From.Asttypes.private_flag -> To.Asttypes.private_flag = +and copy_private_flag : + Ast_408.Asttypes.private_flag -> Ast_407.Asttypes.private_flag = function - | From.Asttypes.Private -> To.Asttypes.Private - | From.Asttypes.Public -> To.Asttypes.Public - + | Ast_408.Asttypes.Private -> Ast_407.Asttypes.Private + | Ast_408.Asttypes.Public -> Ast_407.Asttypes.Public and copy_out_rec_status : - From.Outcometree.out_rec_status -> To.Outcometree.out_rec_status = + Ast_408.Outcometree.out_rec_status -> Ast_407.Outcometree.out_rec_status = function - | From.Outcometree.Orec_not -> To.Outcometree.Orec_not - | From.Outcometree.Orec_first -> To.Outcometree.Orec_first - | From.Outcometree.Orec_next -> To.Outcometree.Orec_next - + | Ast_408.Outcometree.Orec_not -> Ast_407.Outcometree.Orec_not + | Ast_408.Outcometree.Orec_first -> Ast_407.Outcometree.Orec_first + | Ast_408.Outcometree.Orec_next -> Ast_407.Outcometree.Orec_next and copy_out_class_type : - From.Outcometree.out_class_type -> To.Outcometree.out_class_type = - function - | From.Outcometree.Octy_constr (x0,x1) -> - To.Outcometree.Octy_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Octy_arrow (x0,x1,x2) -> - To.Outcometree.Octy_arrow - (x0, (copy_out_type x1), - (copy_out_class_type x2)) - | From.Outcometree.Octy_signature (x0,x1) -> - To.Outcometree.Octy_signature - ((copy_option copy_out_type x0), + Ast_408.Outcometree.out_class_type -> Ast_407.Outcometree.out_class_type = + function + | Ast_408.Outcometree.Octy_constr (x0, x1) -> + Ast_407.Outcometree.Octy_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_408.Outcometree.Octy_arrow (x0, x1, x2) -> + Ast_407.Outcometree.Octy_arrow + (x0, (copy_out_type x1), (copy_out_class_type x2)) + | Ast_408.Outcometree.Octy_signature (x0, x1) -> + Ast_407.Outcometree.Octy_signature + ((Option.map copy_out_type x0), (List.map copy_out_class_sig_item x1)) - and copy_out_class_sig_item : - From.Outcometree.out_class_sig_item -> - To.Outcometree.out_class_sig_item + Ast_408.Outcometree.out_class_sig_item -> + Ast_407.Outcometree.out_class_sig_item = function - | From.Outcometree.Ocsg_constraint (x0,x1) -> - To.Outcometree.Ocsg_constraint - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Ocsg_method (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_method - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - | From.Outcometree.Ocsg_value (x0,x1,x2,x3) -> - To.Outcometree.Ocsg_value - (x0, (copy_bool x1), (copy_bool x2), - (copy_out_type x3)) - + | Ast_408.Outcometree.Ocsg_constraint (x0, x1) -> + Ast_407.Outcometree.Ocsg_constraint + ((copy_out_type x0), (copy_out_type x1)) + | Ast_408.Outcometree.Ocsg_method (x0, x1, x2, x3) -> + Ast_407.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3)) + | Ast_408.Outcometree.Ocsg_value (x0, x1, x2, x3) -> + Ast_407.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3)) and copy_out_type : - From.Outcometree.out_type -> To.Outcometree.out_type = - function - | From.Outcometree.Otyp_abstract -> To.Outcometree.Otyp_abstract - | From.Outcometree.Otyp_open -> To.Outcometree.Otyp_open - | From.Outcometree.Otyp_alias (x0,x1) -> - To.Outcometree.Otyp_alias - ((copy_out_type x0), x1) - | From.Outcometree.Otyp_arrow (x0,x1,x2) -> - To.Outcometree.Otyp_arrow - (x0, (copy_out_type x1), - (copy_out_type x2)) - | From.Outcometree.Otyp_class (x0,x1,x2) -> - To.Outcometree.Otyp_class - ((copy_bool x0), (copy_out_ident x1), - (List.map copy_out_type x2)) - | From.Outcometree.Otyp_constr (x0,x1) -> - To.Outcometree.Otyp_constr - ((copy_out_ident x0), - (List.map copy_out_type x1)) - | From.Outcometree.Otyp_manifest (x0,x1) -> - To.Outcometree.Otyp_manifest - ((copy_out_type x0), - (copy_out_type x1)) - | From.Outcometree.Otyp_object (x0,x1) -> - To.Outcometree.Otyp_object - ((List.map - (fun x -> - let (x0,x1) = x in - (x0, (copy_out_type x1))) x0), - (copy_option copy_bool x1)) - | From.Outcometree.Otyp_record x0 -> - To.Outcometree.Otyp_record + Ast_408.Outcometree.out_type -> Ast_407.Outcometree.out_type = + function + | Ast_408.Outcometree.Otyp_abstract -> Ast_407.Outcometree.Otyp_abstract + | Ast_408.Outcometree.Otyp_open -> Ast_407.Outcometree.Otyp_open + | Ast_408.Outcometree.Otyp_alias (x0, x1) -> + Ast_407.Outcometree.Otyp_alias ((copy_out_type x0), x1) + | Ast_408.Outcometree.Otyp_arrow (x0, x1, x2) -> + Ast_407.Outcometree.Otyp_arrow + (x0, (copy_out_type x1), (copy_out_type x2)) + | Ast_408.Outcometree.Otyp_class (x0, x1, x2) -> + Ast_407.Outcometree.Otyp_class + (x0, (copy_out_ident x1), (List.map copy_out_type x2)) + | Ast_408.Outcometree.Otyp_constr (x0, x1) -> + Ast_407.Outcometree.Otyp_constr + ((copy_out_ident x0), (List.map copy_out_type x1)) + | Ast_408.Outcometree.Otyp_manifest (x0, x1) -> + Ast_407.Outcometree.Otyp_manifest + ((copy_out_type x0), (copy_out_type x1)) + | Ast_408.Outcometree.Otyp_object (x0, x1) -> + Ast_407.Outcometree.Otyp_object + ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0), + (Option.map (fun x -> x) x1)) + | Ast_408.Outcometree.Otyp_record x0 -> + Ast_407.Outcometree.Otyp_record (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), (copy_out_type x2))) - x0) - | From.Outcometree.Otyp_stuff x0 -> To.Outcometree.Otyp_stuff x0 - | From.Outcometree.Otyp_sum x0 -> - To.Outcometree.Otyp_sum + (fun x -> let (x0, x1, x2) = x in (x0, x1, (copy_out_type x2))) x0) + | Ast_408.Outcometree.Otyp_stuff x0 -> Ast_407.Outcometree.Otyp_stuff x0 + | Ast_408.Outcometree.Otyp_sum x0 -> + Ast_407.Outcometree.Otyp_sum (List.map - (fun x -> - let (x0,x1,x2) = x in + (fun x -> + let (x0, x1, x2) = x in (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) x0) - | From.Outcometree.Otyp_tuple x0 -> - To.Outcometree.Otyp_tuple - (List.map copy_out_type x0) - | From.Outcometree.Otyp_var (x0,x1) -> - To.Outcometree.Otyp_var ((copy_bool x0), x1) - | From.Outcometree.Otyp_variant (x0,x1,x2,x3) -> - To.Outcometree.Otyp_variant - ((copy_bool x0), (copy_out_variant x1), - (copy_bool x2), - (copy_option (fun x -> List.map (fun x -> x) x) x3)) - | From.Outcometree.Otyp_poly (x0,x1) -> - To.Outcometree.Otyp_poly - ((List.map (fun x -> x) x0), (copy_out_type x1)) + (Option.map copy_out_type x2))) x0) + | Ast_408.Outcometree.Otyp_tuple x0 -> + Ast_407.Outcometree.Otyp_tuple (List.map copy_out_type x0) + | Ast_408.Outcometree.Otyp_var (x0, x1) -> + Ast_407.Outcometree.Otyp_var (x0, x1) + | Ast_408.Outcometree.Otyp_variant (x0, x1, x2, x3) -> + Ast_407.Outcometree.Otyp_variant + (x0, (copy_out_variant x1), x2, + (Option.map (fun x -> List.map (fun x -> x) x) x3)) + | Ast_408.Outcometree.Otyp_poly (x0, x1) -> + Ast_407.Outcometree.Otyp_poly + ((List.map (fun x -> x) x0), (copy_out_type x1)) | From.Outcometree.Otyp_module (x0,x1,x2) -> To.Outcometree.Otyp_module ((match x0 with @@ -1711,109 +249,68 @@ and copy_out_type : migration_error Location.none Def.Otyp_module), (List.map (fun x -> x) x1), (List.map copy_out_type x2)) - | From.Outcometree.Otyp_attribute (x0,x1) -> - To.Outcometree.Otyp_attribute - ((copy_out_type x0), - (copy_out_attribute x1)) - -and copy_out_string : - From.Outcometree.out_string -> To.Outcometree.out_string = - function - | From.Outcometree.Ostr_string -> To.Outcometree.Ostr_string - | From.Outcometree.Ostr_bytes -> To.Outcometree.Ostr_bytes - + | Ast_408.Outcometree.Otyp_attribute (x0, x1) -> + Ast_407.Outcometree.Otyp_attribute + ((copy_out_type x0), (copy_out_attribute x1)) and copy_out_attribute : - From.Outcometree.out_attribute -> To.Outcometree.out_attribute = - fun { From.Outcometree.oattr_name = oattr_name } -> - { To.Outcometree.oattr_name = oattr_name } - + Ast_408.Outcometree.out_attribute -> Ast_407.Outcometree.out_attribute = + fun { Ast_408.Outcometree.oattr_name = oattr_name } -> + { Ast_407.Outcometree.oattr_name = oattr_name } and copy_out_variant : - From.Outcometree.out_variant -> To.Outcometree.out_variant = + Ast_408.Outcometree.out_variant -> Ast_407.Outcometree.out_variant = function - | From.Outcometree.Ovar_fields x0 -> - To.Outcometree.Ovar_fields + | Ast_408.Outcometree.Ovar_fields x0 -> + Ast_407.Outcometree.Ovar_fields (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (copy_bool x1), - (List.map copy_out_type x2))) x0) - | From.Outcometree.Ovar_typ x0 -> - To.Outcometree.Ovar_typ (copy_out_type x0) - + (fun x -> + let (x0, x1, x2) = x in (x0, x1, (List.map copy_out_type x2))) + x0) + | Ast_408.Outcometree.Ovar_typ x0 -> + Ast_407.Outcometree.Ovar_typ (copy_out_type x0) and copy_out_value : - From.Outcometree.out_value -> To.Outcometree.out_value = - function - | From.Outcometree.Oval_array x0 -> - To.Outcometree.Oval_array - (List.map copy_out_value x0) - | From.Outcometree.Oval_char x0 -> To.Outcometree.Oval_char x0 - | From.Outcometree.Oval_constr (x0,x1) -> - To.Outcometree.Oval_constr - ((copy_out_ident x0), - (List.map copy_out_value x1)) - | From.Outcometree.Oval_ellipsis -> To.Outcometree.Oval_ellipsis - | From.Outcometree.Oval_float x0 -> - To.Outcometree.Oval_float (copy_float x0) - | From.Outcometree.Oval_int x0 -> To.Outcometree.Oval_int x0 - | From.Outcometree.Oval_int32 x0 -> To.Outcometree.Oval_int32 x0 - | From.Outcometree.Oval_int64 x0 -> To.Outcometree.Oval_int64 x0 - | From.Outcometree.Oval_nativeint x0 -> - To.Outcometree.Oval_nativeint x0 - | From.Outcometree.Oval_list x0 -> - To.Outcometree.Oval_list - (List.map copy_out_value x0) - | From.Outcometree.Oval_printer x0 -> - To.Outcometree.Oval_printer x0 - | From.Outcometree.Oval_record x0 -> - To.Outcometree.Oval_record + Ast_408.Outcometree.out_value -> Ast_407.Outcometree.out_value = + function + | Ast_408.Outcometree.Oval_array x0 -> + Ast_407.Outcometree.Oval_array (List.map copy_out_value x0) + | Ast_408.Outcometree.Oval_char x0 -> Ast_407.Outcometree.Oval_char x0 + | Ast_408.Outcometree.Oval_constr (x0, x1) -> + Ast_407.Outcometree.Oval_constr + ((copy_out_ident x0), (List.map copy_out_value x1)) + | Ast_408.Outcometree.Oval_ellipsis -> Ast_407.Outcometree.Oval_ellipsis + | Ast_408.Outcometree.Oval_float x0 -> Ast_407.Outcometree.Oval_float x0 + | Ast_408.Outcometree.Oval_int x0 -> Ast_407.Outcometree.Oval_int x0 + | Ast_408.Outcometree.Oval_int32 x0 -> Ast_407.Outcometree.Oval_int32 x0 + | Ast_408.Outcometree.Oval_int64 x0 -> Ast_407.Outcometree.Oval_int64 x0 + | Ast_408.Outcometree.Oval_nativeint x0 -> + Ast_407.Outcometree.Oval_nativeint x0 + | Ast_408.Outcometree.Oval_list x0 -> + Ast_407.Outcometree.Oval_list (List.map copy_out_value x0) + | Ast_408.Outcometree.Oval_printer x0 -> + Ast_407.Outcometree.Oval_printer x0 + | Ast_408.Outcometree.Oval_record x0 -> + Ast_407.Outcometree.Oval_record (List.map - (fun x -> - let (x0,x1) = x in - ((copy_out_ident x0), - (copy_out_value x1))) x0) - | From.Outcometree.Oval_string (x0, x1, x2) -> - To.Outcometree.Oval_string (x0, x1, copy_out_string x2) - | From.Outcometree.Oval_stuff x0 -> To.Outcometree.Oval_stuff x0 - | From.Outcometree.Oval_tuple x0 -> - To.Outcometree.Oval_tuple - (List.map copy_out_value x0) - | From.Outcometree.Oval_variant (x0,x1) -> - To.Outcometree.Oval_variant - (x0, (copy_option copy_out_value x1)) - -and copy_float : float -> float = fun x -> x - + (fun x -> + let (x0, x1) = x in ((copy_out_ident x0), (copy_out_value x1))) + x0) + | Ast_408.Outcometree.Oval_string (x0, x1, x2) -> + Ast_407.Outcometree.Oval_string (x0, x1, (copy_out_string x2)) + | Ast_408.Outcometree.Oval_stuff x0 -> Ast_407.Outcometree.Oval_stuff x0 + | Ast_408.Outcometree.Oval_tuple x0 -> + Ast_407.Outcometree.Oval_tuple (List.map copy_out_value x0) + | Ast_408.Outcometree.Oval_variant (x0, x1) -> + Ast_407.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1)) +and copy_out_string : + Ast_408.Outcometree.out_string -> Ast_407.Outcometree.out_string = + function + | Ast_408.Outcometree.Ostr_string -> Ast_407.Outcometree.Ostr_string + | Ast_408.Outcometree.Ostr_bytes -> Ast_407.Outcometree.Ostr_bytes and copy_out_ident : - From.Outcometree.out_ident -> To.Outcometree.out_ident = + Ast_408.Outcometree.out_ident -> Ast_407.Outcometree.out_ident = function - | From.Outcometree.Oide_apply (x0,x1) -> - To.Outcometree.Oide_apply - ((copy_out_ident x0), - (copy_out_ident x1)) - | From.Outcometree.Oide_dot (x0,x1) -> - To.Outcometree.Oide_dot - ((copy_out_ident x0), x1) + | Ast_408.Outcometree.Oide_apply (x0, x1) -> + Ast_407.Outcometree.Oide_apply + ((copy_out_ident x0), (copy_out_ident x1)) + | Ast_408.Outcometree.Oide_dot (x0, x1) -> + Ast_407.Outcometree.Oide_dot ((copy_out_ident x0), x1) | From.Outcometree.Oide_ident x0 -> To.Outcometree.Oide_ident x0.From.Outcometree.printed_name - -let copy_out_type_extension : - From.Outcometree.out_type_extension -> To.Outcometree.out_type_extension = - fun - { From.Outcometree.otyext_name = otyext_name; - From.Outcometree.otyext_params = otyext_params; - From.Outcometree.otyext_constructors = otyext_constructors; - From.Outcometree.otyext_private = otyext_private } - -> - { - To.Outcometree.otyext_name = otyext_name; - To.Outcometree.otyext_params = - (List.map (fun x -> x) otyext_params); - To.Outcometree.otyext_constructors = - (List.map - (fun x -> - let (x0,x1,x2) = x in - (x0, (List.map copy_out_type x1), - (copy_option copy_out_type x2))) - otyext_constructors); - To.Outcometree.otyext_private = - (copy_private_flag otyext_private) - } diff --git a/src/vendored-omp/src/migrate_parsetree_408_409.ml b/src/vendored-omp/src/migrate_parsetree_408_409.ml index 48bfd1e48..9e2ee6155 100644 --- a/src/vendored-omp/src/migrate_parsetree_408_409.ml +++ b/src/vendored-omp/src/migrate_parsetree_408_409.ml @@ -15,126 +15,3 @@ include Migrate_parsetree_408_409_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload"; - "binding_op"; "module_substitution"; "open_declaration"; "type_exception" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - binding_op; - module_substitution; - open_declaration; - type_exception; - (*$*) - } as mapper) -> - let module Def = Migrate_parsetree_def in - let module R = Migrate_parsetree_409_408_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - binding_op = (fun _ x -> copy_binding_op (binding_op mapper (R.copy_binding_op x))); - module_substitution = (fun _ x -> copy_module_substitution (module_substitution mapper (R.copy_module_substitution x))); - open_declaration = (fun _ x -> copy_open_declaration (open_declaration mapper (R.copy_open_declaration x))); - type_exception = (fun _ x -> copy_type_exception (type_exception mapper (R.copy_type_exception x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_408_409_migrate.ml b/src/vendored-omp/src/migrate_parsetree_408_409_migrate.ml index 297b53bc2..c0e74e414 100644 --- a/src/vendored-omp/src/migrate_parsetree_408_409_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_408_409_migrate.ml @@ -153,6 +153,11 @@ and copy_out_extension_constructor : (Option.map copy_out_type oext_ret_type); Ast_409.Outcometree.oext_private = (copy_private_flag oext_private) } +and copy_private_flag : + Ast_408.Asttypes.private_flag -> Ast_409.Asttypes.private_flag = + function + | Ast_408.Asttypes.Private -> Ast_409.Asttypes.Private + | Ast_408.Asttypes.Public -> Ast_409.Asttypes.Public and copy_out_rec_status : Ast_408.Outcometree.out_rec_status -> Ast_409.Outcometree.out_rec_status = function @@ -304,1198 +309,3 @@ and copy_out_name : Ast_408.Outcometree.out_name -> Ast_409.Outcometree.out_name = fun { Ast_408.Outcometree.printed_name = printed_name } -> { Ast_409.Outcometree.printed_name = printed_name } -and copy_toplevel_phrase : - Ast_408.Parsetree.toplevel_phrase -> Ast_409.Parsetree.toplevel_phrase = - function - | Ast_408.Parsetree.Ptop_def x0 -> - Ast_409.Parsetree.Ptop_def (copy_structure x0) - | Ast_408.Parsetree.Ptop_dir x0 -> - Ast_409.Parsetree.Ptop_dir (copy_toplevel_directive x0) -and copy_toplevel_directive : - Ast_408.Parsetree.toplevel_directive -> - Ast_409.Parsetree.toplevel_directive - = - fun - { Ast_408.Parsetree.pdir_name = pdir_name; - Ast_408.Parsetree.pdir_arg = pdir_arg; - Ast_408.Parsetree.pdir_loc = pdir_loc } - -> - { - Ast_409.Parsetree.pdir_name = (copy_loc (fun x -> x) pdir_name); - Ast_409.Parsetree.pdir_arg = - (Option.map copy_directive_argument pdir_arg); - Ast_409.Parsetree.pdir_loc = (copy_location pdir_loc) - } -and copy_directive_argument : - Ast_408.Parsetree.directive_argument -> - Ast_409.Parsetree.directive_argument - = - fun - { Ast_408.Parsetree.pdira_desc = pdira_desc; - Ast_408.Parsetree.pdira_loc = pdira_loc } - -> - { - Ast_409.Parsetree.pdira_desc = - (copy_directive_argument_desc pdira_desc); - Ast_409.Parsetree.pdira_loc = (copy_location pdira_loc) - } -and copy_directive_argument_desc : - Ast_408.Parsetree.directive_argument_desc -> - Ast_409.Parsetree.directive_argument_desc - = - function - | Ast_408.Parsetree.Pdir_string x0 -> Ast_409.Parsetree.Pdir_string x0 - | Ast_408.Parsetree.Pdir_int (x0, x1) -> - Ast_409.Parsetree.Pdir_int (x0, (Option.map (fun x -> x) x1)) - | Ast_408.Parsetree.Pdir_ident x0 -> - Ast_409.Parsetree.Pdir_ident (copy_Longident_t x0) - | Ast_408.Parsetree.Pdir_bool x0 -> Ast_409.Parsetree.Pdir_bool x0 -and copy_typ : Ast_408.Parsetree.typ -> Ast_409.Parsetree.typ = - fun x -> copy_core_type x -and copy_pat : Ast_408.Parsetree.pat -> Ast_409.Parsetree.pat = - fun x -> copy_pattern x -and copy_expr : Ast_408.Parsetree.expr -> Ast_409.Parsetree.expr = - fun x -> copy_expression x -and copy_expression : - Ast_408.Parsetree.expression -> Ast_409.Parsetree.expression = - fun - { Ast_408.Parsetree.pexp_desc = pexp_desc; - Ast_408.Parsetree.pexp_loc = pexp_loc; - Ast_408.Parsetree.pexp_loc_stack = pexp_loc_stack; - Ast_408.Parsetree.pexp_attributes = pexp_attributes } - -> - { - Ast_409.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - Ast_409.Parsetree.pexp_loc = (copy_location pexp_loc); - Ast_409.Parsetree.pexp_loc_stack = - (List.map copy_location pexp_loc_stack); - Ast_409.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } -and copy_expression_desc : - Ast_408.Parsetree.expression_desc -> Ast_409.Parsetree.expression_desc = - function - | Ast_408.Parsetree.Pexp_ident x0 -> - Ast_409.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) - | Ast_408.Parsetree.Pexp_constant x0 -> - Ast_409.Parsetree.Pexp_constant (copy_constant x0) - | Ast_408.Parsetree.Pexp_let (x0, x1, x2) -> - Ast_409.Parsetree.Pexp_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_expression x2)) - | Ast_408.Parsetree.Pexp_function x0 -> - Ast_409.Parsetree.Pexp_function (copy_cases x0) - | Ast_408.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_409.Parsetree.Pexp_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_expression x3)) - | Ast_408.Parsetree.Pexp_apply (x0, x1) -> - Ast_409.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_408.Parsetree.Pexp_match (x0, x1) -> - Ast_409.Parsetree.Pexp_match ((copy_expression x0), (copy_cases x1)) - | Ast_408.Parsetree.Pexp_try (x0, x1) -> - Ast_409.Parsetree.Pexp_try ((copy_expression x0), (copy_cases x1)) - | Ast_408.Parsetree.Pexp_tuple x0 -> - Ast_409.Parsetree.Pexp_tuple (List.map copy_expression x0) - | Ast_408.Parsetree.Pexp_construct (x0, x1) -> - Ast_409.Parsetree.Pexp_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_expression x1)) - | Ast_408.Parsetree.Pexp_variant (x0, x1) -> - Ast_409.Parsetree.Pexp_variant - ((copy_label x0), (Option.map copy_expression x1)) - | Ast_408.Parsetree.Pexp_record (x0, x1) -> - Ast_409.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_expression x1))) x0), - (Option.map copy_expression x1)) - | Ast_408.Parsetree.Pexp_field (x0, x1) -> - Ast_409.Parsetree.Pexp_field - ((copy_expression x0), (copy_loc copy_Longident_t x1)) - | Ast_408.Parsetree.Pexp_setfield (x0, x1, x2) -> - Ast_409.Parsetree.Pexp_setfield - ((copy_expression x0), (copy_loc copy_Longident_t x1), - (copy_expression x2)) - | Ast_408.Parsetree.Pexp_array x0 -> - Ast_409.Parsetree.Pexp_array (List.map copy_expression x0) - | Ast_408.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> - Ast_409.Parsetree.Pexp_ifthenelse - ((copy_expression x0), (copy_expression x1), - (Option.map copy_expression x2)) - | Ast_408.Parsetree.Pexp_sequence (x0, x1) -> - Ast_409.Parsetree.Pexp_sequence - ((copy_expression x0), (copy_expression x1)) - | Ast_408.Parsetree.Pexp_while (x0, x1) -> - Ast_409.Parsetree.Pexp_while - ((copy_expression x0), (copy_expression x1)) - | Ast_408.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> - Ast_409.Parsetree.Pexp_for - ((copy_pattern x0), (copy_expression x1), (copy_expression x2), - (copy_direction_flag x3), (copy_expression x4)) - | Ast_408.Parsetree.Pexp_constraint (x0, x1) -> - Ast_409.Parsetree.Pexp_constraint - ((copy_expression x0), (copy_core_type x1)) - | Ast_408.Parsetree.Pexp_coerce (x0, x1, x2) -> - Ast_409.Parsetree.Pexp_coerce - ((copy_expression x0), (Option.map copy_core_type x1), - (copy_core_type x2)) - | Ast_408.Parsetree.Pexp_send (x0, x1) -> - Ast_409.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc copy_label x1)) - | Ast_408.Parsetree.Pexp_new x0 -> - Ast_409.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) - | Ast_408.Parsetree.Pexp_setinstvar (x0, x1) -> - Ast_409.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), (copy_expression x1)) - | Ast_408.Parsetree.Pexp_override x0 -> - Ast_409.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_label x0), (copy_expression x1))) x0) - | Ast_408.Parsetree.Pexp_letmodule (x0, x1, x2) -> - Ast_409.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> x) x0), (copy_module_expr x1), - (copy_expression x2)) - | Ast_408.Parsetree.Pexp_letexception (x0, x1) -> - Ast_409.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), (copy_expression x1)) - | Ast_408.Parsetree.Pexp_assert x0 -> - Ast_409.Parsetree.Pexp_assert (copy_expression x0) - | Ast_408.Parsetree.Pexp_lazy x0 -> - Ast_409.Parsetree.Pexp_lazy (copy_expression x0) - | Ast_408.Parsetree.Pexp_poly (x0, x1) -> - Ast_409.Parsetree.Pexp_poly - ((copy_expression x0), (Option.map copy_core_type x1)) - | Ast_408.Parsetree.Pexp_object x0 -> - Ast_409.Parsetree.Pexp_object (copy_class_structure x0) - | Ast_408.Parsetree.Pexp_newtype (x0, x1) -> - Ast_409.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | Ast_408.Parsetree.Pexp_pack x0 -> - Ast_409.Parsetree.Pexp_pack (copy_module_expr x0) - | Ast_408.Parsetree.Pexp_open (x0, x1) -> - Ast_409.Parsetree.Pexp_open - ((copy_open_declaration x0), (copy_expression x1)) - | Ast_408.Parsetree.Pexp_letop x0 -> - Ast_409.Parsetree.Pexp_letop (copy_letop x0) - | Ast_408.Parsetree.Pexp_extension x0 -> - Ast_409.Parsetree.Pexp_extension (copy_extension x0) - | Ast_408.Parsetree.Pexp_unreachable -> Ast_409.Parsetree.Pexp_unreachable -and copy_letop : Ast_408.Parsetree.letop -> Ast_409.Parsetree.letop = - fun - { Ast_408.Parsetree.let_ = let_; Ast_408.Parsetree.ands = ands; - Ast_408.Parsetree.body = body } - -> - { - Ast_409.Parsetree.let_ = (copy_binding_op let_); - Ast_409.Parsetree.ands = (List.map copy_binding_op ands); - Ast_409.Parsetree.body = (copy_expression body) - } -and copy_binding_op : - Ast_408.Parsetree.binding_op -> Ast_409.Parsetree.binding_op = - fun - { Ast_408.Parsetree.pbop_op = pbop_op; - Ast_408.Parsetree.pbop_pat = pbop_pat; - Ast_408.Parsetree.pbop_exp = pbop_exp; - Ast_408.Parsetree.pbop_loc = pbop_loc } - -> - { - Ast_409.Parsetree.pbop_op = (copy_loc (fun x -> x) pbop_op); - Ast_409.Parsetree.pbop_pat = (copy_pattern pbop_pat); - Ast_409.Parsetree.pbop_exp = (copy_expression pbop_exp); - Ast_409.Parsetree.pbop_loc = (copy_location pbop_loc) - } -and copy_direction_flag : - Ast_408.Asttypes.direction_flag -> Ast_409.Asttypes.direction_flag = - function - | Ast_408.Asttypes.Upto -> Ast_409.Asttypes.Upto - | Ast_408.Asttypes.Downto -> Ast_409.Asttypes.Downto -and copy_cases : Ast_408.Parsetree.cases -> Ast_409.Parsetree.cases = - fun x -> List.map copy_case x -and copy_case : Ast_408.Parsetree.case -> Ast_409.Parsetree.case = - fun - { Ast_408.Parsetree.pc_lhs = pc_lhs; - Ast_408.Parsetree.pc_guard = pc_guard; - Ast_408.Parsetree.pc_rhs = pc_rhs } - -> - { - Ast_409.Parsetree.pc_lhs = (copy_pattern pc_lhs); - Ast_409.Parsetree.pc_guard = (Option.map copy_expression pc_guard); - Ast_409.Parsetree.pc_rhs = (copy_expression pc_rhs) - } -and copy_value_binding : - Ast_408.Parsetree.value_binding -> Ast_409.Parsetree.value_binding = - fun - { Ast_408.Parsetree.pvb_pat = pvb_pat; - Ast_408.Parsetree.pvb_expr = pvb_expr; - Ast_408.Parsetree.pvb_attributes = pvb_attributes; - Ast_408.Parsetree.pvb_loc = pvb_loc } - -> - { - Ast_409.Parsetree.pvb_pat = (copy_pattern pvb_pat); - Ast_409.Parsetree.pvb_expr = (copy_expression pvb_expr); - Ast_409.Parsetree.pvb_attributes = (copy_attributes pvb_attributes); - Ast_409.Parsetree.pvb_loc = (copy_location pvb_loc) - } -and copy_pattern : Ast_408.Parsetree.pattern -> Ast_409.Parsetree.pattern = - fun - { Ast_408.Parsetree.ppat_desc = ppat_desc; - Ast_408.Parsetree.ppat_loc = ppat_loc; - Ast_408.Parsetree.ppat_loc_stack = ppat_loc_stack; - Ast_408.Parsetree.ppat_attributes = ppat_attributes } - -> - { - Ast_409.Parsetree.ppat_desc = (copy_pattern_desc ppat_desc); - Ast_409.Parsetree.ppat_loc = (copy_location ppat_loc); - Ast_409.Parsetree.ppat_loc_stack = - (List.map copy_location ppat_loc_stack); - Ast_409.Parsetree.ppat_attributes = (copy_attributes ppat_attributes) - } -and copy_pattern_desc : - Ast_408.Parsetree.pattern_desc -> Ast_409.Parsetree.pattern_desc = - function - | Ast_408.Parsetree.Ppat_any -> Ast_409.Parsetree.Ppat_any - | Ast_408.Parsetree.Ppat_var x0 -> - Ast_409.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | Ast_408.Parsetree.Ppat_alias (x0, x1) -> - Ast_409.Parsetree.Ppat_alias - ((copy_pattern x0), (copy_loc (fun x -> x) x1)) - | Ast_408.Parsetree.Ppat_constant x0 -> - Ast_409.Parsetree.Ppat_constant (copy_constant x0) - | Ast_408.Parsetree.Ppat_interval (x0, x1) -> - Ast_409.Parsetree.Ppat_interval - ((copy_constant x0), (copy_constant x1)) - | Ast_408.Parsetree.Ppat_tuple x0 -> - Ast_409.Parsetree.Ppat_tuple (List.map copy_pattern x0) - | Ast_408.Parsetree.Ppat_construct (x0, x1) -> - Ast_409.Parsetree.Ppat_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_pattern x1)) - | Ast_408.Parsetree.Ppat_variant (x0, x1) -> - Ast_409.Parsetree.Ppat_variant - ((copy_label x0), (Option.map copy_pattern x1)) - | Ast_408.Parsetree.Ppat_record (x0, x1) -> - Ast_409.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | Ast_408.Parsetree.Ppat_array x0 -> - Ast_409.Parsetree.Ppat_array (List.map copy_pattern x0) - | Ast_408.Parsetree.Ppat_or (x0, x1) -> - Ast_409.Parsetree.Ppat_or ((copy_pattern x0), (copy_pattern x1)) - | Ast_408.Parsetree.Ppat_constraint (x0, x1) -> - Ast_409.Parsetree.Ppat_constraint - ((copy_pattern x0), (copy_core_type x1)) - | Ast_408.Parsetree.Ppat_type x0 -> - Ast_409.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) - | Ast_408.Parsetree.Ppat_lazy x0 -> - Ast_409.Parsetree.Ppat_lazy (copy_pattern x0) - | Ast_408.Parsetree.Ppat_unpack x0 -> - Ast_409.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) - | Ast_408.Parsetree.Ppat_exception x0 -> - Ast_409.Parsetree.Ppat_exception (copy_pattern x0) - | Ast_408.Parsetree.Ppat_extension x0 -> - Ast_409.Parsetree.Ppat_extension (copy_extension x0) - | Ast_408.Parsetree.Ppat_open (x0, x1) -> - Ast_409.Parsetree.Ppat_open - ((copy_loc copy_Longident_t x0), (copy_pattern x1)) -and copy_core_type : - Ast_408.Parsetree.core_type -> Ast_409.Parsetree.core_type = - fun - { Ast_408.Parsetree.ptyp_desc = ptyp_desc; - Ast_408.Parsetree.ptyp_loc = ptyp_loc; - Ast_408.Parsetree.ptyp_loc_stack = ptyp_loc_stack; - Ast_408.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - Ast_409.Parsetree.ptyp_desc = (copy_core_type_desc ptyp_desc); - Ast_409.Parsetree.ptyp_loc = (copy_location ptyp_loc); - Ast_409.Parsetree.ptyp_loc_stack = - (List.map copy_location ptyp_loc_stack); - Ast_409.Parsetree.ptyp_attributes = (copy_attributes ptyp_attributes) - } -and copy_core_type_desc : - Ast_408.Parsetree.core_type_desc -> Ast_409.Parsetree.core_type_desc = - function - | Ast_408.Parsetree.Ptyp_any -> Ast_409.Parsetree.Ptyp_any - | Ast_408.Parsetree.Ptyp_var x0 -> Ast_409.Parsetree.Ptyp_var x0 - | Ast_408.Parsetree.Ptyp_arrow (x0, x1, x2) -> - Ast_409.Parsetree.Ptyp_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_core_type x2)) - | Ast_408.Parsetree.Ptyp_tuple x0 -> - Ast_409.Parsetree.Ptyp_tuple (List.map copy_core_type x0) - | Ast_408.Parsetree.Ptyp_constr (x0, x1) -> - Ast_409.Parsetree.Ptyp_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_408.Parsetree.Ptyp_object (x0, x1) -> - Ast_409.Parsetree.Ptyp_object - ((List.map copy_object_field x0), (copy_closed_flag x1)) - | Ast_408.Parsetree.Ptyp_class (x0, x1) -> - Ast_409.Parsetree.Ptyp_class - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_408.Parsetree.Ptyp_alias (x0, x1) -> - Ast_409.Parsetree.Ptyp_alias ((copy_core_type x0), x1) - | Ast_408.Parsetree.Ptyp_variant (x0, x1, x2) -> - Ast_409.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), (copy_closed_flag x1), - (Option.map (fun x -> List.map copy_label x) x2)) - | Ast_408.Parsetree.Ptyp_poly (x0, x1) -> - Ast_409.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | Ast_408.Parsetree.Ptyp_package x0 -> - Ast_409.Parsetree.Ptyp_package (copy_package_type x0) - | Ast_408.Parsetree.Ptyp_extension x0 -> - Ast_409.Parsetree.Ptyp_extension (copy_extension x0) -and copy_package_type : - Ast_408.Parsetree.package_type -> Ast_409.Parsetree.package_type = - fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_core_type x1))) x1)) -and copy_row_field : - Ast_408.Parsetree.row_field -> Ast_409.Parsetree.row_field = - fun - { Ast_408.Parsetree.prf_desc = prf_desc; - Ast_408.Parsetree.prf_loc = prf_loc; - Ast_408.Parsetree.prf_attributes = prf_attributes } - -> - { - Ast_409.Parsetree.prf_desc = (copy_row_field_desc prf_desc); - Ast_409.Parsetree.prf_loc = (copy_location prf_loc); - Ast_409.Parsetree.prf_attributes = (copy_attributes prf_attributes) - } -and copy_row_field_desc : - Ast_408.Parsetree.row_field_desc -> Ast_409.Parsetree.row_field_desc = - function - | Ast_408.Parsetree.Rtag (x0, x1, x2) -> - Ast_409.Parsetree.Rtag - ((copy_loc copy_label x0), x1, (List.map copy_core_type x2)) - | Ast_408.Parsetree.Rinherit x0 -> - Ast_409.Parsetree.Rinherit (copy_core_type x0) -and copy_object_field : - Ast_408.Parsetree.object_field -> Ast_409.Parsetree.object_field = - fun - { Ast_408.Parsetree.pof_desc = pof_desc; - Ast_408.Parsetree.pof_loc = pof_loc; - Ast_408.Parsetree.pof_attributes = pof_attributes } - -> - { - Ast_409.Parsetree.pof_desc = (copy_object_field_desc pof_desc); - Ast_409.Parsetree.pof_loc = (copy_location pof_loc); - Ast_409.Parsetree.pof_attributes = (copy_attributes pof_attributes) - } -and copy_attributes : - Ast_408.Parsetree.attributes -> Ast_409.Parsetree.attributes = - fun x -> List.map copy_attribute x -and copy_attribute : - Ast_408.Parsetree.attribute -> Ast_409.Parsetree.attribute = - fun - { Ast_408.Parsetree.attr_name = attr_name; - Ast_408.Parsetree.attr_payload = attr_payload; - Ast_408.Parsetree.attr_loc = attr_loc } - -> - { - Ast_409.Parsetree.attr_name = (copy_loc (fun x -> x) attr_name); - Ast_409.Parsetree.attr_payload = (copy_payload attr_payload); - Ast_409.Parsetree.attr_loc = (copy_location attr_loc) - } -and copy_payload : Ast_408.Parsetree.payload -> Ast_409.Parsetree.payload = - function - | Ast_408.Parsetree.PStr x0 -> Ast_409.Parsetree.PStr (copy_structure x0) - | Ast_408.Parsetree.PSig x0 -> Ast_409.Parsetree.PSig (copy_signature x0) - | Ast_408.Parsetree.PTyp x0 -> Ast_409.Parsetree.PTyp (copy_core_type x0) - | Ast_408.Parsetree.PPat (x0, x1) -> - Ast_409.Parsetree.PPat - ((copy_pattern x0), (Option.map copy_expression x1)) -and copy_structure : - Ast_408.Parsetree.structure -> Ast_409.Parsetree.structure = - fun x -> List.map copy_structure_item x -and copy_structure_item : - Ast_408.Parsetree.structure_item -> Ast_409.Parsetree.structure_item = - fun - { Ast_408.Parsetree.pstr_desc = pstr_desc; - Ast_408.Parsetree.pstr_loc = pstr_loc } - -> - { - Ast_409.Parsetree.pstr_desc = (copy_structure_item_desc pstr_desc); - Ast_409.Parsetree.pstr_loc = (copy_location pstr_loc) - } -and copy_structure_item_desc : - Ast_408.Parsetree.structure_item_desc -> - Ast_409.Parsetree.structure_item_desc - = - function - | Ast_408.Parsetree.Pstr_eval (x0, x1) -> - Ast_409.Parsetree.Pstr_eval - ((copy_expression x0), (copy_attributes x1)) - | Ast_408.Parsetree.Pstr_value (x0, x1) -> - Ast_409.Parsetree.Pstr_value - ((copy_rec_flag x0), (List.map copy_value_binding x1)) - | Ast_408.Parsetree.Pstr_primitive x0 -> - Ast_409.Parsetree.Pstr_primitive (copy_value_description x0) - | Ast_408.Parsetree.Pstr_type (x0, x1) -> - Ast_409.Parsetree.Pstr_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_408.Parsetree.Pstr_typext x0 -> - Ast_409.Parsetree.Pstr_typext (copy_type_extension x0) - | Ast_408.Parsetree.Pstr_exception x0 -> - Ast_409.Parsetree.Pstr_exception (copy_type_exception x0) - | Ast_408.Parsetree.Pstr_module x0 -> - Ast_409.Parsetree.Pstr_module (copy_module_binding x0) - | Ast_408.Parsetree.Pstr_recmodule x0 -> - Ast_409.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) - | Ast_408.Parsetree.Pstr_modtype x0 -> - Ast_409.Parsetree.Pstr_modtype (copy_module_type_declaration x0) - | Ast_408.Parsetree.Pstr_open x0 -> - Ast_409.Parsetree.Pstr_open (copy_open_declaration x0) - | Ast_408.Parsetree.Pstr_class x0 -> - Ast_409.Parsetree.Pstr_class (List.map copy_class_declaration x0) - | Ast_408.Parsetree.Pstr_class_type x0 -> - Ast_409.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | Ast_408.Parsetree.Pstr_include x0 -> - Ast_409.Parsetree.Pstr_include (copy_include_declaration x0) - | Ast_408.Parsetree.Pstr_attribute x0 -> - Ast_409.Parsetree.Pstr_attribute (copy_attribute x0) - | Ast_408.Parsetree.Pstr_extension (x0, x1) -> - Ast_409.Parsetree.Pstr_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_include_declaration : - Ast_408.Parsetree.include_declaration -> - Ast_409.Parsetree.include_declaration - = fun x -> copy_include_infos copy_module_expr x -and copy_class_declaration : - Ast_408.Parsetree.class_declaration -> Ast_409.Parsetree.class_declaration - = fun x -> copy_class_infos copy_class_expr x -and copy_class_expr : - Ast_408.Parsetree.class_expr -> Ast_409.Parsetree.class_expr = - fun - { Ast_408.Parsetree.pcl_desc = pcl_desc; - Ast_408.Parsetree.pcl_loc = pcl_loc; - Ast_408.Parsetree.pcl_attributes = pcl_attributes } - -> - { - Ast_409.Parsetree.pcl_desc = (copy_class_expr_desc pcl_desc); - Ast_409.Parsetree.pcl_loc = (copy_location pcl_loc); - Ast_409.Parsetree.pcl_attributes = (copy_attributes pcl_attributes) - } -and copy_class_expr_desc : - Ast_408.Parsetree.class_expr_desc -> Ast_409.Parsetree.class_expr_desc = - function - | Ast_408.Parsetree.Pcl_constr (x0, x1) -> - Ast_409.Parsetree.Pcl_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_408.Parsetree.Pcl_structure x0 -> - Ast_409.Parsetree.Pcl_structure (copy_class_structure x0) - | Ast_408.Parsetree.Pcl_fun (x0, x1, x2, x3) -> - Ast_409.Parsetree.Pcl_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_class_expr x3)) - | Ast_408.Parsetree.Pcl_apply (x0, x1) -> - Ast_409.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_408.Parsetree.Pcl_let (x0, x1, x2) -> - Ast_409.Parsetree.Pcl_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_class_expr x2)) - | Ast_408.Parsetree.Pcl_constraint (x0, x1) -> - Ast_409.Parsetree.Pcl_constraint - ((copy_class_expr x0), (copy_class_type x1)) - | Ast_408.Parsetree.Pcl_extension x0 -> - Ast_409.Parsetree.Pcl_extension (copy_extension x0) - | Ast_408.Parsetree.Pcl_open (x0, x1) -> - Ast_409.Parsetree.Pcl_open - ((copy_open_description x0), (copy_class_expr x1)) -and copy_class_structure : - Ast_408.Parsetree.class_structure -> Ast_409.Parsetree.class_structure = - fun - { Ast_408.Parsetree.pcstr_self = pcstr_self; - Ast_408.Parsetree.pcstr_fields = pcstr_fields } - -> - { - Ast_409.Parsetree.pcstr_self = (copy_pattern pcstr_self); - Ast_409.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } -and copy_class_field : - Ast_408.Parsetree.class_field -> Ast_409.Parsetree.class_field = - fun - { Ast_408.Parsetree.pcf_desc = pcf_desc; - Ast_408.Parsetree.pcf_loc = pcf_loc; - Ast_408.Parsetree.pcf_attributes = pcf_attributes } - -> - { - Ast_409.Parsetree.pcf_desc = (copy_class_field_desc pcf_desc); - Ast_409.Parsetree.pcf_loc = (copy_location pcf_loc); - Ast_409.Parsetree.pcf_attributes = (copy_attributes pcf_attributes) - } -and copy_class_field_desc : - Ast_408.Parsetree.class_field_desc -> Ast_409.Parsetree.class_field_desc = - function - | Ast_408.Parsetree.Pcf_inherit (x0, x1, x2) -> - Ast_409.Parsetree.Pcf_inherit - ((copy_override_flag x0), (copy_class_expr x1), - (Option.map (fun x -> copy_loc (fun x -> x) x) x2)) - | Ast_408.Parsetree.Pcf_val x0 -> - Ast_409.Parsetree.Pcf_val - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | Ast_408.Parsetree.Pcf_method x0 -> - Ast_409.Parsetree.Pcf_method - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_class_field_kind x2))) - | Ast_408.Parsetree.Pcf_constraint x0 -> - Ast_409.Parsetree.Pcf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_408.Parsetree.Pcf_initializer x0 -> - Ast_409.Parsetree.Pcf_initializer (copy_expression x0) - | Ast_408.Parsetree.Pcf_attribute x0 -> - Ast_409.Parsetree.Pcf_attribute (copy_attribute x0) - | Ast_408.Parsetree.Pcf_extension x0 -> - Ast_409.Parsetree.Pcf_extension (copy_extension x0) -and copy_class_field_kind : - Ast_408.Parsetree.class_field_kind -> Ast_409.Parsetree.class_field_kind = - function - | Ast_408.Parsetree.Cfk_virtual x0 -> - Ast_409.Parsetree.Cfk_virtual (copy_core_type x0) - | Ast_408.Parsetree.Cfk_concrete (x0, x1) -> - Ast_409.Parsetree.Cfk_concrete - ((copy_override_flag x0), (copy_expression x1)) -and copy_open_declaration : - Ast_408.Parsetree.open_declaration -> Ast_409.Parsetree.open_declaration = - fun x -> copy_open_infos copy_module_expr x -and copy_module_binding : - Ast_408.Parsetree.module_binding -> Ast_409.Parsetree.module_binding = - fun - { Ast_408.Parsetree.pmb_name = pmb_name; - Ast_408.Parsetree.pmb_expr = pmb_expr; - Ast_408.Parsetree.pmb_attributes = pmb_attributes; - Ast_408.Parsetree.pmb_loc = pmb_loc } - -> - { - Ast_409.Parsetree.pmb_name = (copy_loc (fun x -> x) pmb_name); - Ast_409.Parsetree.pmb_expr = (copy_module_expr pmb_expr); - Ast_409.Parsetree.pmb_attributes = (copy_attributes pmb_attributes); - Ast_409.Parsetree.pmb_loc = (copy_location pmb_loc) - } -and copy_module_expr : - Ast_408.Parsetree.module_expr -> Ast_409.Parsetree.module_expr = - fun - { Ast_408.Parsetree.pmod_desc = pmod_desc; - Ast_408.Parsetree.pmod_loc = pmod_loc; - Ast_408.Parsetree.pmod_attributes = pmod_attributes } - -> - { - Ast_409.Parsetree.pmod_desc = (copy_module_expr_desc pmod_desc); - Ast_409.Parsetree.pmod_loc = (copy_location pmod_loc); - Ast_409.Parsetree.pmod_attributes = (copy_attributes pmod_attributes) - } -and copy_module_expr_desc : - Ast_408.Parsetree.module_expr_desc -> Ast_409.Parsetree.module_expr_desc = - function - | Ast_408.Parsetree.Pmod_ident x0 -> - Ast_409.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) - | Ast_408.Parsetree.Pmod_structure x0 -> - Ast_409.Parsetree.Pmod_structure (copy_structure x0) - | Ast_408.Parsetree.Pmod_functor (x0, x1, x2) -> - Ast_409.Parsetree.Pmod_functor - ((copy_loc (fun x -> x) x0), (Option.map copy_module_type x1), - (copy_module_expr x2)) - | Ast_408.Parsetree.Pmod_apply (x0, x1) -> - Ast_409.Parsetree.Pmod_apply - ((copy_module_expr x0), (copy_module_expr x1)) - | Ast_408.Parsetree.Pmod_constraint (x0, x1) -> - Ast_409.Parsetree.Pmod_constraint - ((copy_module_expr x0), (copy_module_type x1)) - | Ast_408.Parsetree.Pmod_unpack x0 -> - Ast_409.Parsetree.Pmod_unpack (copy_expression x0) - | Ast_408.Parsetree.Pmod_extension x0 -> - Ast_409.Parsetree.Pmod_extension (copy_extension x0) -and copy_module_type : - Ast_408.Parsetree.module_type -> Ast_409.Parsetree.module_type = - fun - { Ast_408.Parsetree.pmty_desc = pmty_desc; - Ast_408.Parsetree.pmty_loc = pmty_loc; - Ast_408.Parsetree.pmty_attributes = pmty_attributes } - -> - { - Ast_409.Parsetree.pmty_desc = (copy_module_type_desc pmty_desc); - Ast_409.Parsetree.pmty_loc = (copy_location pmty_loc); - Ast_409.Parsetree.pmty_attributes = (copy_attributes pmty_attributes) - } -and copy_module_type_desc : - Ast_408.Parsetree.module_type_desc -> Ast_409.Parsetree.module_type_desc = - function - | Ast_408.Parsetree.Pmty_ident x0 -> - Ast_409.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) - | Ast_408.Parsetree.Pmty_signature x0 -> - Ast_409.Parsetree.Pmty_signature (copy_signature x0) - | Ast_408.Parsetree.Pmty_functor (x0, x1, x2) -> - Ast_409.Parsetree.Pmty_functor - ((copy_loc (fun x -> x) x0), (Option.map copy_module_type x1), - (copy_module_type x2)) - | Ast_408.Parsetree.Pmty_with (x0, x1) -> - Ast_409.Parsetree.Pmty_with - ((copy_module_type x0), (List.map copy_with_constraint x1)) - | Ast_408.Parsetree.Pmty_typeof x0 -> - Ast_409.Parsetree.Pmty_typeof (copy_module_expr x0) - | Ast_408.Parsetree.Pmty_extension x0 -> - Ast_409.Parsetree.Pmty_extension (copy_extension x0) - | Ast_408.Parsetree.Pmty_alias x0 -> - Ast_409.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) -and copy_with_constraint : - Ast_408.Parsetree.with_constraint -> Ast_409.Parsetree.with_constraint = - function - | Ast_408.Parsetree.Pwith_type (x0, x1) -> - Ast_409.Parsetree.Pwith_type - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_408.Parsetree.Pwith_module (x0, x1) -> - Ast_409.Parsetree.Pwith_module - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) - | Ast_408.Parsetree.Pwith_typesubst (x0, x1) -> - Ast_409.Parsetree.Pwith_typesubst - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_408.Parsetree.Pwith_modsubst (x0, x1) -> - Ast_409.Parsetree.Pwith_modsubst - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) -and copy_signature : - Ast_408.Parsetree.signature -> Ast_409.Parsetree.signature = - fun x -> List.map copy_signature_item x -and copy_signature_item : - Ast_408.Parsetree.signature_item -> Ast_409.Parsetree.signature_item = - fun - { Ast_408.Parsetree.psig_desc = psig_desc; - Ast_408.Parsetree.psig_loc = psig_loc } - -> - { - Ast_409.Parsetree.psig_desc = (copy_signature_item_desc psig_desc); - Ast_409.Parsetree.psig_loc = (copy_location psig_loc) - } -and copy_signature_item_desc : - Ast_408.Parsetree.signature_item_desc -> - Ast_409.Parsetree.signature_item_desc - = - function - | Ast_408.Parsetree.Psig_value x0 -> - Ast_409.Parsetree.Psig_value (copy_value_description x0) - | Ast_408.Parsetree.Psig_type (x0, x1) -> - Ast_409.Parsetree.Psig_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_408.Parsetree.Psig_typesubst x0 -> - Ast_409.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) - | Ast_408.Parsetree.Psig_typext x0 -> - Ast_409.Parsetree.Psig_typext (copy_type_extension x0) - | Ast_408.Parsetree.Psig_exception x0 -> - Ast_409.Parsetree.Psig_exception (copy_type_exception x0) - | Ast_408.Parsetree.Psig_module x0 -> - Ast_409.Parsetree.Psig_module (copy_module_declaration x0) - | Ast_408.Parsetree.Psig_modsubst x0 -> - Ast_409.Parsetree.Psig_modsubst (copy_module_substitution x0) - | Ast_408.Parsetree.Psig_recmodule x0 -> - Ast_409.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) - | Ast_408.Parsetree.Psig_modtype x0 -> - Ast_409.Parsetree.Psig_modtype (copy_module_type_declaration x0) - | Ast_408.Parsetree.Psig_open x0 -> - Ast_409.Parsetree.Psig_open (copy_open_description x0) - | Ast_408.Parsetree.Psig_include x0 -> - Ast_409.Parsetree.Psig_include (copy_include_description x0) - | Ast_408.Parsetree.Psig_class x0 -> - Ast_409.Parsetree.Psig_class (List.map copy_class_description x0) - | Ast_408.Parsetree.Psig_class_type x0 -> - Ast_409.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | Ast_408.Parsetree.Psig_attribute x0 -> - Ast_409.Parsetree.Psig_attribute (copy_attribute x0) - | Ast_408.Parsetree.Psig_extension (x0, x1) -> - Ast_409.Parsetree.Psig_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_class_type_declaration : - Ast_408.Parsetree.class_type_declaration -> - Ast_409.Parsetree.class_type_declaration - = fun x -> copy_class_infos copy_class_type x -and copy_class_description : - Ast_408.Parsetree.class_description -> Ast_409.Parsetree.class_description - = fun x -> copy_class_infos copy_class_type x -and copy_class_type : - Ast_408.Parsetree.class_type -> Ast_409.Parsetree.class_type = - fun - { Ast_408.Parsetree.pcty_desc = pcty_desc; - Ast_408.Parsetree.pcty_loc = pcty_loc; - Ast_408.Parsetree.pcty_attributes = pcty_attributes } - -> - { - Ast_409.Parsetree.pcty_desc = (copy_class_type_desc pcty_desc); - Ast_409.Parsetree.pcty_loc = (copy_location pcty_loc); - Ast_409.Parsetree.pcty_attributes = (copy_attributes pcty_attributes) - } -and copy_class_type_desc : - Ast_408.Parsetree.class_type_desc -> Ast_409.Parsetree.class_type_desc = - function - | Ast_408.Parsetree.Pcty_constr (x0, x1) -> - Ast_409.Parsetree.Pcty_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_408.Parsetree.Pcty_signature x0 -> - Ast_409.Parsetree.Pcty_signature (copy_class_signature x0) - | Ast_408.Parsetree.Pcty_arrow (x0, x1, x2) -> - Ast_409.Parsetree.Pcty_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_class_type x2)) - | Ast_408.Parsetree.Pcty_extension x0 -> - Ast_409.Parsetree.Pcty_extension (copy_extension x0) - | Ast_408.Parsetree.Pcty_open (x0, x1) -> - Ast_409.Parsetree.Pcty_open - ((copy_open_description x0), (copy_class_type x1)) -and copy_class_signature : - Ast_408.Parsetree.class_signature -> Ast_409.Parsetree.class_signature = - fun - { Ast_408.Parsetree.pcsig_self = pcsig_self; - Ast_408.Parsetree.pcsig_fields = pcsig_fields } - -> - { - Ast_409.Parsetree.pcsig_self = (copy_core_type pcsig_self); - Ast_409.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } -and copy_class_type_field : - Ast_408.Parsetree.class_type_field -> Ast_409.Parsetree.class_type_field = - fun - { Ast_408.Parsetree.pctf_desc = pctf_desc; - Ast_408.Parsetree.pctf_loc = pctf_loc; - Ast_408.Parsetree.pctf_attributes = pctf_attributes } - -> - { - Ast_409.Parsetree.pctf_desc = (copy_class_type_field_desc pctf_desc); - Ast_409.Parsetree.pctf_loc = (copy_location pctf_loc); - Ast_409.Parsetree.pctf_attributes = (copy_attributes pctf_attributes) - } -and copy_class_type_field_desc : - Ast_408.Parsetree.class_type_field_desc -> - Ast_409.Parsetree.class_type_field_desc - = - function - | Ast_408.Parsetree.Pctf_inherit x0 -> - Ast_409.Parsetree.Pctf_inherit (copy_class_type x0) - | Ast_408.Parsetree.Pctf_val x0 -> - Ast_409.Parsetree.Pctf_val - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_408.Parsetree.Pctf_method x0 -> - Ast_409.Parsetree.Pctf_method - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_408.Parsetree.Pctf_constraint x0 -> - Ast_409.Parsetree.Pctf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_408.Parsetree.Pctf_attribute x0 -> - Ast_409.Parsetree.Pctf_attribute (copy_attribute x0) - | Ast_408.Parsetree.Pctf_extension x0 -> - Ast_409.Parsetree.Pctf_extension (copy_extension x0) -and copy_extension : - Ast_408.Parsetree.extension -> Ast_409.Parsetree.extension = - fun x -> - let (x0, x1) = x in ((copy_loc (fun x -> x) x0), (copy_payload x1)) -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_408.Parsetree.class_infos -> 'g0 Ast_409.Parsetree.class_infos - = - fun f0 -> - fun - { Ast_408.Parsetree.pci_virt = pci_virt; - Ast_408.Parsetree.pci_params = pci_params; - Ast_408.Parsetree.pci_name = pci_name; - Ast_408.Parsetree.pci_expr = pci_expr; - Ast_408.Parsetree.pci_loc = pci_loc; - Ast_408.Parsetree.pci_attributes = pci_attributes } - -> - { - Ast_409.Parsetree.pci_virt = (copy_virtual_flag pci_virt); - Ast_409.Parsetree.pci_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - pci_params); - Ast_409.Parsetree.pci_name = (copy_loc (fun x -> x) pci_name); - Ast_409.Parsetree.pci_expr = (f0 pci_expr); - Ast_409.Parsetree.pci_loc = (copy_location pci_loc); - Ast_409.Parsetree.pci_attributes = (copy_attributes pci_attributes) - } -and copy_virtual_flag : - Ast_408.Asttypes.virtual_flag -> Ast_409.Asttypes.virtual_flag = - function - | Ast_408.Asttypes.Virtual -> Ast_409.Asttypes.Virtual - | Ast_408.Asttypes.Concrete -> Ast_409.Asttypes.Concrete -and copy_include_description : - Ast_408.Parsetree.include_description -> - Ast_409.Parsetree.include_description - = fun x -> copy_include_infos copy_module_type x -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_408.Parsetree.include_infos -> - 'g0 Ast_409.Parsetree.include_infos - = - fun f0 -> - fun - { Ast_408.Parsetree.pincl_mod = pincl_mod; - Ast_408.Parsetree.pincl_loc = pincl_loc; - Ast_408.Parsetree.pincl_attributes = pincl_attributes } - -> - { - Ast_409.Parsetree.pincl_mod = (f0 pincl_mod); - Ast_409.Parsetree.pincl_loc = (copy_location pincl_loc); - Ast_409.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } -and copy_open_description : - Ast_408.Parsetree.open_description -> Ast_409.Parsetree.open_description = - fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x -and copy_open_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_408.Parsetree.open_infos -> 'g0 Ast_409.Parsetree.open_infos - = - fun f0 -> - fun - { Ast_408.Parsetree.popen_expr = popen_expr; - Ast_408.Parsetree.popen_override = popen_override; - Ast_408.Parsetree.popen_loc = popen_loc; - Ast_408.Parsetree.popen_attributes = popen_attributes } - -> - { - Ast_409.Parsetree.popen_expr = (f0 popen_expr); - Ast_409.Parsetree.popen_override = - (copy_override_flag popen_override); - Ast_409.Parsetree.popen_loc = (copy_location popen_loc); - Ast_409.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } -and copy_override_flag : - Ast_408.Asttypes.override_flag -> Ast_409.Asttypes.override_flag = - function - | Ast_408.Asttypes.Override -> Ast_409.Asttypes.Override - | Ast_408.Asttypes.Fresh -> Ast_409.Asttypes.Fresh -and copy_module_type_declaration : - Ast_408.Parsetree.module_type_declaration -> - Ast_409.Parsetree.module_type_declaration - = - fun - { Ast_408.Parsetree.pmtd_name = pmtd_name; - Ast_408.Parsetree.pmtd_type = pmtd_type; - Ast_408.Parsetree.pmtd_attributes = pmtd_attributes; - Ast_408.Parsetree.pmtd_loc = pmtd_loc } - -> - { - Ast_409.Parsetree.pmtd_name = (copy_loc (fun x -> x) pmtd_name); - Ast_409.Parsetree.pmtd_type = (Option.map copy_module_type pmtd_type); - Ast_409.Parsetree.pmtd_attributes = (copy_attributes pmtd_attributes); - Ast_409.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } -and copy_module_substitution : - Ast_408.Parsetree.module_substitution -> - Ast_409.Parsetree.module_substitution - = - fun - { Ast_408.Parsetree.pms_name = pms_name; - Ast_408.Parsetree.pms_manifest = pms_manifest; - Ast_408.Parsetree.pms_attributes = pms_attributes; - Ast_408.Parsetree.pms_loc = pms_loc } - -> - { - Ast_409.Parsetree.pms_name = (copy_loc (fun x -> x) pms_name); - Ast_409.Parsetree.pms_manifest = - (copy_loc copy_Longident_t pms_manifest); - Ast_409.Parsetree.pms_attributes = (copy_attributes pms_attributes); - Ast_409.Parsetree.pms_loc = (copy_location pms_loc) - } -and copy_module_declaration : - Ast_408.Parsetree.module_declaration -> - Ast_409.Parsetree.module_declaration - = - fun - { Ast_408.Parsetree.pmd_name = pmd_name; - Ast_408.Parsetree.pmd_type = pmd_type; - Ast_408.Parsetree.pmd_attributes = pmd_attributes; - Ast_408.Parsetree.pmd_loc = pmd_loc } - -> - { - Ast_409.Parsetree.pmd_name = (copy_loc (fun x -> x) pmd_name); - Ast_409.Parsetree.pmd_type = (copy_module_type pmd_type); - Ast_409.Parsetree.pmd_attributes = (copy_attributes pmd_attributes); - Ast_409.Parsetree.pmd_loc = (copy_location pmd_loc) - } -and copy_type_exception : - Ast_408.Parsetree.type_exception -> Ast_409.Parsetree.type_exception = - fun - { Ast_408.Parsetree.ptyexn_constructor = ptyexn_constructor; - Ast_408.Parsetree.ptyexn_loc = ptyexn_loc; - Ast_408.Parsetree.ptyexn_attributes = ptyexn_attributes } - -> - { - Ast_409.Parsetree.ptyexn_constructor = - (copy_extension_constructor ptyexn_constructor); - Ast_409.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); - Ast_409.Parsetree.ptyexn_attributes = - (copy_attributes ptyexn_attributes) - } -and copy_type_extension : - Ast_408.Parsetree.type_extension -> Ast_409.Parsetree.type_extension = - fun - { Ast_408.Parsetree.ptyext_path = ptyext_path; - Ast_408.Parsetree.ptyext_params = ptyext_params; - Ast_408.Parsetree.ptyext_constructors = ptyext_constructors; - Ast_408.Parsetree.ptyext_private = ptyext_private; - Ast_408.Parsetree.ptyext_loc = ptyext_loc; - Ast_408.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - Ast_409.Parsetree.ptyext_path = (copy_loc copy_Longident_t ptyext_path); - Ast_409.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - ptyext_params); - Ast_409.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor ptyext_constructors); - Ast_409.Parsetree.ptyext_private = (copy_private_flag ptyext_private); - Ast_409.Parsetree.ptyext_loc = (copy_location ptyext_loc); - Ast_409.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } -and copy_extension_constructor : - Ast_408.Parsetree.extension_constructor -> - Ast_409.Parsetree.extension_constructor - = - fun - { Ast_408.Parsetree.pext_name = pext_name; - Ast_408.Parsetree.pext_kind = pext_kind; - Ast_408.Parsetree.pext_loc = pext_loc; - Ast_408.Parsetree.pext_attributes = pext_attributes } - -> - { - Ast_409.Parsetree.pext_name = (copy_loc (fun x -> x) pext_name); - Ast_409.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - Ast_409.Parsetree.pext_loc = (copy_location pext_loc); - Ast_409.Parsetree.pext_attributes = (copy_attributes pext_attributes) - } -and copy_extension_constructor_kind : - Ast_408.Parsetree.extension_constructor_kind -> - Ast_409.Parsetree.extension_constructor_kind - = - function - | Ast_408.Parsetree.Pext_decl (x0, x1) -> - Ast_409.Parsetree.Pext_decl - ((copy_constructor_arguments x0), (Option.map copy_core_type x1)) - | Ast_408.Parsetree.Pext_rebind x0 -> - Ast_409.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) -and copy_type_declaration : - Ast_408.Parsetree.type_declaration -> Ast_409.Parsetree.type_declaration = - fun - { Ast_408.Parsetree.ptype_name = ptype_name; - Ast_408.Parsetree.ptype_params = ptype_params; - Ast_408.Parsetree.ptype_cstrs = ptype_cstrs; - Ast_408.Parsetree.ptype_kind = ptype_kind; - Ast_408.Parsetree.ptype_private = ptype_private; - Ast_408.Parsetree.ptype_manifest = ptype_manifest; - Ast_408.Parsetree.ptype_attributes = ptype_attributes; - Ast_408.Parsetree.ptype_loc = ptype_loc } - -> - { - Ast_409.Parsetree.ptype_name = (copy_loc (fun x -> x) ptype_name); - Ast_409.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - ptype_params); - Ast_409.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0, x1, x2) = x in - ((copy_core_type x0), (copy_core_type x1), (copy_location x2))) - ptype_cstrs); - Ast_409.Parsetree.ptype_kind = (copy_type_kind ptype_kind); - Ast_409.Parsetree.ptype_private = (copy_private_flag ptype_private); - Ast_409.Parsetree.ptype_manifest = - (Option.map copy_core_type ptype_manifest); - Ast_409.Parsetree.ptype_attributes = (copy_attributes ptype_attributes); - Ast_409.Parsetree.ptype_loc = (copy_location ptype_loc) - } -and copy_private_flag : - Ast_408.Asttypes.private_flag -> Ast_409.Asttypes.private_flag = - function - | Ast_408.Asttypes.Private -> Ast_409.Asttypes.Private - | Ast_408.Asttypes.Public -> Ast_409.Asttypes.Public -and copy_type_kind : - Ast_408.Parsetree.type_kind -> Ast_409.Parsetree.type_kind = - function - | Ast_408.Parsetree.Ptype_abstract -> Ast_409.Parsetree.Ptype_abstract - | Ast_408.Parsetree.Ptype_variant x0 -> - Ast_409.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | Ast_408.Parsetree.Ptype_record x0 -> - Ast_409.Parsetree.Ptype_record (List.map copy_label_declaration x0) - | Ast_408.Parsetree.Ptype_open -> Ast_409.Parsetree.Ptype_open -and copy_constructor_declaration : - Ast_408.Parsetree.constructor_declaration -> - Ast_409.Parsetree.constructor_declaration - = - fun - { Ast_408.Parsetree.pcd_name = pcd_name; - Ast_408.Parsetree.pcd_args = pcd_args; - Ast_408.Parsetree.pcd_res = pcd_res; - Ast_408.Parsetree.pcd_loc = pcd_loc; - Ast_408.Parsetree.pcd_attributes = pcd_attributes } - -> - { - Ast_409.Parsetree.pcd_name = (copy_loc (fun x -> x) pcd_name); - Ast_409.Parsetree.pcd_args = (copy_constructor_arguments pcd_args); - Ast_409.Parsetree.pcd_res = (Option.map copy_core_type pcd_res); - Ast_409.Parsetree.pcd_loc = (copy_location pcd_loc); - Ast_409.Parsetree.pcd_attributes = (copy_attributes pcd_attributes) - } -and copy_constructor_arguments : - Ast_408.Parsetree.constructor_arguments -> - Ast_409.Parsetree.constructor_arguments - = - function - | Ast_408.Parsetree.Pcstr_tuple x0 -> - Ast_409.Parsetree.Pcstr_tuple (List.map copy_core_type x0) - | Ast_408.Parsetree.Pcstr_record x0 -> - Ast_409.Parsetree.Pcstr_record (List.map copy_label_declaration x0) -and copy_label_declaration : - Ast_408.Parsetree.label_declaration -> Ast_409.Parsetree.label_declaration - = - fun - { Ast_408.Parsetree.pld_name = pld_name; - Ast_408.Parsetree.pld_mutable = pld_mutable; - Ast_408.Parsetree.pld_type = pld_type; - Ast_408.Parsetree.pld_loc = pld_loc; - Ast_408.Parsetree.pld_attributes = pld_attributes } - -> - { - Ast_409.Parsetree.pld_name = (copy_loc (fun x -> x) pld_name); - Ast_409.Parsetree.pld_mutable = (copy_mutable_flag pld_mutable); - Ast_409.Parsetree.pld_type = (copy_core_type pld_type); - Ast_409.Parsetree.pld_loc = (copy_location pld_loc); - Ast_409.Parsetree.pld_attributes = (copy_attributes pld_attributes) - } -and copy_mutable_flag : - Ast_408.Asttypes.mutable_flag -> Ast_409.Asttypes.mutable_flag = - function - | Ast_408.Asttypes.Immutable -> Ast_409.Asttypes.Immutable - | Ast_408.Asttypes.Mutable -> Ast_409.Asttypes.Mutable -and copy_variance : Ast_408.Asttypes.variance -> Ast_409.Asttypes.variance = - function - | Ast_408.Asttypes.Covariant -> Ast_409.Asttypes.Covariant - | Ast_408.Asttypes.Contravariant -> Ast_409.Asttypes.Contravariant - | Ast_408.Asttypes.Invariant -> Ast_409.Asttypes.Invariant -and copy_value_description : - Ast_408.Parsetree.value_description -> Ast_409.Parsetree.value_description - = - fun - { Ast_408.Parsetree.pval_name = pval_name; - Ast_408.Parsetree.pval_type = pval_type; - Ast_408.Parsetree.pval_prim = pval_prim; - Ast_408.Parsetree.pval_attributes = pval_attributes; - Ast_408.Parsetree.pval_loc = pval_loc } - -> - { - Ast_409.Parsetree.pval_name = (copy_loc (fun x -> x) pval_name); - Ast_409.Parsetree.pval_type = (copy_core_type pval_type); - Ast_409.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - Ast_409.Parsetree.pval_attributes = (copy_attributes pval_attributes); - Ast_409.Parsetree.pval_loc = (copy_location pval_loc) - } -and copy_object_field_desc : - Ast_408.Parsetree.object_field_desc -> Ast_409.Parsetree.object_field_desc - = - function - | Ast_408.Parsetree.Otag (x0, x1) -> - Ast_409.Parsetree.Otag ((copy_loc copy_label x0), (copy_core_type x1)) - | Ast_408.Parsetree.Oinherit x0 -> - Ast_409.Parsetree.Oinherit (copy_core_type x0) -and copy_arg_label : Ast_408.Asttypes.arg_label -> Ast_409.Asttypes.arg_label - = - function - | Ast_408.Asttypes.Nolabel -> Ast_409.Asttypes.Nolabel - | Ast_408.Asttypes.Labelled x0 -> Ast_409.Asttypes.Labelled x0 - | Ast_408.Asttypes.Optional x0 -> Ast_409.Asttypes.Optional x0 -and copy_closed_flag : - Ast_408.Asttypes.closed_flag -> Ast_409.Asttypes.closed_flag = - function - | Ast_408.Asttypes.Closed -> Ast_409.Asttypes.Closed - | Ast_408.Asttypes.Open -> Ast_409.Asttypes.Open -and copy_label : Ast_408.Asttypes.label -> Ast_409.Asttypes.label = - fun x -> x -and copy_rec_flag : Ast_408.Asttypes.rec_flag -> Ast_409.Asttypes.rec_flag = - function - | Ast_408.Asttypes.Nonrecursive -> Ast_409.Asttypes.Nonrecursive - | Ast_408.Asttypes.Recursive -> Ast_409.Asttypes.Recursive -and copy_constant : Ast_408.Parsetree.constant -> Ast_409.Parsetree.constant - = - function - | Ast_408.Parsetree.Pconst_integer (x0, x1) -> - Ast_409.Parsetree.Pconst_integer (x0, (Option.map (fun x -> x) x1)) - | Ast_408.Parsetree.Pconst_char x0 -> Ast_409.Parsetree.Pconst_char x0 - | Ast_408.Parsetree.Pconst_string (x0, x1) -> - Ast_409.Parsetree.Pconst_string (x0, (Option.map (fun x -> x) x1)) - | Ast_408.Parsetree.Pconst_float (x0, x1) -> - Ast_409.Parsetree.Pconst_float (x0, (Option.map (fun x -> x) x1)) -and copy_Longident_t : Ast_408.Longident.t -> Ast_409.Longident.t = - function - | Ast_408.Longident.Lident x0 -> Ast_409.Longident.Lident x0 - | Ast_408.Longident.Ldot (x0, x1) -> - Ast_409.Longident.Ldot ((copy_Longident_t x0), x1) - | Ast_408.Longident.Lapply (x0, x1) -> - Ast_409.Longident.Lapply ((copy_Longident_t x0), (copy_Longident_t x1)) -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 Ast_408.Asttypes.loc -> 'g0 Ast_409.Asttypes.loc - = - fun f0 -> - fun { Ast_408.Asttypes.txt = txt; Ast_408.Asttypes.loc = loc } -> - { - Ast_409.Asttypes.txt = (f0 txt); - Ast_409.Asttypes.loc = (copy_location loc) - } -and copy_location : Ast_408.Location.t -> Ast_409.Location.t = - fun - { Ast_408.Location.loc_start = loc_start; - Ast_408.Location.loc_end = loc_end; - Ast_408.Location.loc_ghost = loc_ghost } - -> - { - Ast_409.Location.loc_start = (copy_position loc_start); - Ast_409.Location.loc_end = (copy_position loc_end); - Ast_409.Location.loc_ghost = loc_ghost - } -and copy_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum - } diff --git a/src/vendored-omp/src/migrate_parsetree_409_408.ml b/src/vendored-omp/src/migrate_parsetree_409_408.ml index b0754d676..6ca433ce4 100644 --- a/src/vendored-omp/src/migrate_parsetree_409_408.ml +++ b/src/vendored-omp/src/migrate_parsetree_409_408.ml @@ -15,126 +15,3 @@ include Migrate_parsetree_409_408_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload"; - "binding_op"; "module_substitution"; "open_declaration"; "type_exception" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - binding_op; - module_substitution; - open_declaration; - type_exception; - (*$*) - } as mapper) -> - let module Def = Migrate_parsetree_def in - let module R = Migrate_parsetree_408_409_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - binding_op = (fun _ x -> copy_binding_op (binding_op mapper (R.copy_binding_op x))); - module_substitution = (fun _ x -> copy_module_substitution (module_substitution mapper (R.copy_module_substitution x))); - open_declaration = (fun _ x -> copy_open_declaration (open_declaration mapper (R.copy_open_declaration x))); - type_exception = (fun _ x -> copy_type_exception (type_exception mapper (R.copy_type_exception x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_409_408_migrate.ml b/src/vendored-omp/src/migrate_parsetree_409_408_migrate.ml index 3cddd11fd..5abf394e7 100644 --- a/src/vendored-omp/src/migrate_parsetree_409_408_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_409_408_migrate.ml @@ -153,6 +153,11 @@ and copy_out_extension_constructor : (Option.map copy_out_type oext_ret_type); Ast_408.Outcometree.oext_private = (copy_private_flag oext_private) } +and copy_private_flag : + Ast_409.Asttypes.private_flag -> Ast_408.Asttypes.private_flag = + function + | Ast_409.Asttypes.Private -> Ast_408.Asttypes.Private + | Ast_409.Asttypes.Public -> Ast_408.Asttypes.Public and copy_out_rec_status : Ast_409.Outcometree.out_rec_status -> Ast_408.Outcometree.out_rec_status = function @@ -304,1198 +309,3 @@ and copy_out_name : Ast_409.Outcometree.out_name -> Ast_408.Outcometree.out_name = fun { Ast_409.Outcometree.printed_name = printed_name } -> { Ast_408.Outcometree.printed_name = printed_name } -and copy_toplevel_phrase : - Ast_409.Parsetree.toplevel_phrase -> Ast_408.Parsetree.toplevel_phrase = - function - | Ast_409.Parsetree.Ptop_def x0 -> - Ast_408.Parsetree.Ptop_def (copy_structure x0) - | Ast_409.Parsetree.Ptop_dir x0 -> - Ast_408.Parsetree.Ptop_dir (copy_toplevel_directive x0) -and copy_toplevel_directive : - Ast_409.Parsetree.toplevel_directive -> - Ast_408.Parsetree.toplevel_directive - = - fun - { Ast_409.Parsetree.pdir_name = pdir_name; - Ast_409.Parsetree.pdir_arg = pdir_arg; - Ast_409.Parsetree.pdir_loc = pdir_loc } - -> - { - Ast_408.Parsetree.pdir_name = (copy_loc (fun x -> x) pdir_name); - Ast_408.Parsetree.pdir_arg = - (Option.map copy_directive_argument pdir_arg); - Ast_408.Parsetree.pdir_loc = (copy_location pdir_loc) - } -and copy_directive_argument : - Ast_409.Parsetree.directive_argument -> - Ast_408.Parsetree.directive_argument - = - fun - { Ast_409.Parsetree.pdira_desc = pdira_desc; - Ast_409.Parsetree.pdira_loc = pdira_loc } - -> - { - Ast_408.Parsetree.pdira_desc = - (copy_directive_argument_desc pdira_desc); - Ast_408.Parsetree.pdira_loc = (copy_location pdira_loc) - } -and copy_directive_argument_desc : - Ast_409.Parsetree.directive_argument_desc -> - Ast_408.Parsetree.directive_argument_desc - = - function - | Ast_409.Parsetree.Pdir_string x0 -> Ast_408.Parsetree.Pdir_string x0 - | Ast_409.Parsetree.Pdir_int (x0, x1) -> - Ast_408.Parsetree.Pdir_int (x0, (Option.map (fun x -> x) x1)) - | Ast_409.Parsetree.Pdir_ident x0 -> - Ast_408.Parsetree.Pdir_ident (copy_Longident_t x0) - | Ast_409.Parsetree.Pdir_bool x0 -> Ast_408.Parsetree.Pdir_bool x0 -and copy_typ : Ast_409.Parsetree.typ -> Ast_408.Parsetree.typ = - fun x -> copy_core_type x -and copy_pat : Ast_409.Parsetree.pat -> Ast_408.Parsetree.pat = - fun x -> copy_pattern x -and copy_expr : Ast_409.Parsetree.expr -> Ast_408.Parsetree.expr = - fun x -> copy_expression x -and copy_expression : - Ast_409.Parsetree.expression -> Ast_408.Parsetree.expression = - fun - { Ast_409.Parsetree.pexp_desc = pexp_desc; - Ast_409.Parsetree.pexp_loc = pexp_loc; - Ast_409.Parsetree.pexp_loc_stack = pexp_loc_stack; - Ast_409.Parsetree.pexp_attributes = pexp_attributes } - -> - { - Ast_408.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - Ast_408.Parsetree.pexp_loc = (copy_location pexp_loc); - Ast_408.Parsetree.pexp_loc_stack = - (List.map copy_location pexp_loc_stack); - Ast_408.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } -and copy_expression_desc : - Ast_409.Parsetree.expression_desc -> Ast_408.Parsetree.expression_desc = - function - | Ast_409.Parsetree.Pexp_ident x0 -> - Ast_408.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) - | Ast_409.Parsetree.Pexp_constant x0 -> - Ast_408.Parsetree.Pexp_constant (copy_constant x0) - | Ast_409.Parsetree.Pexp_let (x0, x1, x2) -> - Ast_408.Parsetree.Pexp_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_expression x2)) - | Ast_409.Parsetree.Pexp_function x0 -> - Ast_408.Parsetree.Pexp_function (copy_cases x0) - | Ast_409.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_408.Parsetree.Pexp_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_expression x3)) - | Ast_409.Parsetree.Pexp_apply (x0, x1) -> - Ast_408.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_409.Parsetree.Pexp_match (x0, x1) -> - Ast_408.Parsetree.Pexp_match ((copy_expression x0), (copy_cases x1)) - | Ast_409.Parsetree.Pexp_try (x0, x1) -> - Ast_408.Parsetree.Pexp_try ((copy_expression x0), (copy_cases x1)) - | Ast_409.Parsetree.Pexp_tuple x0 -> - Ast_408.Parsetree.Pexp_tuple (List.map copy_expression x0) - | Ast_409.Parsetree.Pexp_construct (x0, x1) -> - Ast_408.Parsetree.Pexp_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_expression x1)) - | Ast_409.Parsetree.Pexp_variant (x0, x1) -> - Ast_408.Parsetree.Pexp_variant - ((copy_label x0), (Option.map copy_expression x1)) - | Ast_409.Parsetree.Pexp_record (x0, x1) -> - Ast_408.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_expression x1))) x0), - (Option.map copy_expression x1)) - | Ast_409.Parsetree.Pexp_field (x0, x1) -> - Ast_408.Parsetree.Pexp_field - ((copy_expression x0), (copy_loc copy_Longident_t x1)) - | Ast_409.Parsetree.Pexp_setfield (x0, x1, x2) -> - Ast_408.Parsetree.Pexp_setfield - ((copy_expression x0), (copy_loc copy_Longident_t x1), - (copy_expression x2)) - | Ast_409.Parsetree.Pexp_array x0 -> - Ast_408.Parsetree.Pexp_array (List.map copy_expression x0) - | Ast_409.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> - Ast_408.Parsetree.Pexp_ifthenelse - ((copy_expression x0), (copy_expression x1), - (Option.map copy_expression x2)) - | Ast_409.Parsetree.Pexp_sequence (x0, x1) -> - Ast_408.Parsetree.Pexp_sequence - ((copy_expression x0), (copy_expression x1)) - | Ast_409.Parsetree.Pexp_while (x0, x1) -> - Ast_408.Parsetree.Pexp_while - ((copy_expression x0), (copy_expression x1)) - | Ast_409.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> - Ast_408.Parsetree.Pexp_for - ((copy_pattern x0), (copy_expression x1), (copy_expression x2), - (copy_direction_flag x3), (copy_expression x4)) - | Ast_409.Parsetree.Pexp_constraint (x0, x1) -> - Ast_408.Parsetree.Pexp_constraint - ((copy_expression x0), (copy_core_type x1)) - | Ast_409.Parsetree.Pexp_coerce (x0, x1, x2) -> - Ast_408.Parsetree.Pexp_coerce - ((copy_expression x0), (Option.map copy_core_type x1), - (copy_core_type x2)) - | Ast_409.Parsetree.Pexp_send (x0, x1) -> - Ast_408.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc copy_label x1)) - | Ast_409.Parsetree.Pexp_new x0 -> - Ast_408.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) - | Ast_409.Parsetree.Pexp_setinstvar (x0, x1) -> - Ast_408.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), (copy_expression x1)) - | Ast_409.Parsetree.Pexp_override x0 -> - Ast_408.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_label x0), (copy_expression x1))) x0) - | Ast_409.Parsetree.Pexp_letmodule (x0, x1, x2) -> - Ast_408.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> x) x0), (copy_module_expr x1), - (copy_expression x2)) - | Ast_409.Parsetree.Pexp_letexception (x0, x1) -> - Ast_408.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), (copy_expression x1)) - | Ast_409.Parsetree.Pexp_assert x0 -> - Ast_408.Parsetree.Pexp_assert (copy_expression x0) - | Ast_409.Parsetree.Pexp_lazy x0 -> - Ast_408.Parsetree.Pexp_lazy (copy_expression x0) - | Ast_409.Parsetree.Pexp_poly (x0, x1) -> - Ast_408.Parsetree.Pexp_poly - ((copy_expression x0), (Option.map copy_core_type x1)) - | Ast_409.Parsetree.Pexp_object x0 -> - Ast_408.Parsetree.Pexp_object (copy_class_structure x0) - | Ast_409.Parsetree.Pexp_newtype (x0, x1) -> - Ast_408.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | Ast_409.Parsetree.Pexp_pack x0 -> - Ast_408.Parsetree.Pexp_pack (copy_module_expr x0) - | Ast_409.Parsetree.Pexp_open (x0, x1) -> - Ast_408.Parsetree.Pexp_open - ((copy_open_declaration x0), (copy_expression x1)) - | Ast_409.Parsetree.Pexp_letop x0 -> - Ast_408.Parsetree.Pexp_letop (copy_letop x0) - | Ast_409.Parsetree.Pexp_extension x0 -> - Ast_408.Parsetree.Pexp_extension (copy_extension x0) - | Ast_409.Parsetree.Pexp_unreachable -> Ast_408.Parsetree.Pexp_unreachable -and copy_letop : Ast_409.Parsetree.letop -> Ast_408.Parsetree.letop = - fun - { Ast_409.Parsetree.let_ = let_; Ast_409.Parsetree.ands = ands; - Ast_409.Parsetree.body = body } - -> - { - Ast_408.Parsetree.let_ = (copy_binding_op let_); - Ast_408.Parsetree.ands = (List.map copy_binding_op ands); - Ast_408.Parsetree.body = (copy_expression body) - } -and copy_binding_op : - Ast_409.Parsetree.binding_op -> Ast_408.Parsetree.binding_op = - fun - { Ast_409.Parsetree.pbop_op = pbop_op; - Ast_409.Parsetree.pbop_pat = pbop_pat; - Ast_409.Parsetree.pbop_exp = pbop_exp; - Ast_409.Parsetree.pbop_loc = pbop_loc } - -> - { - Ast_408.Parsetree.pbop_op = (copy_loc (fun x -> x) pbop_op); - Ast_408.Parsetree.pbop_pat = (copy_pattern pbop_pat); - Ast_408.Parsetree.pbop_exp = (copy_expression pbop_exp); - Ast_408.Parsetree.pbop_loc = (copy_location pbop_loc) - } -and copy_direction_flag : - Ast_409.Asttypes.direction_flag -> Ast_408.Asttypes.direction_flag = - function - | Ast_409.Asttypes.Upto -> Ast_408.Asttypes.Upto - | Ast_409.Asttypes.Downto -> Ast_408.Asttypes.Downto -and copy_cases : Ast_409.Parsetree.cases -> Ast_408.Parsetree.cases = - fun x -> List.map copy_case x -and copy_case : Ast_409.Parsetree.case -> Ast_408.Parsetree.case = - fun - { Ast_409.Parsetree.pc_lhs = pc_lhs; - Ast_409.Parsetree.pc_guard = pc_guard; - Ast_409.Parsetree.pc_rhs = pc_rhs } - -> - { - Ast_408.Parsetree.pc_lhs = (copy_pattern pc_lhs); - Ast_408.Parsetree.pc_guard = (Option.map copy_expression pc_guard); - Ast_408.Parsetree.pc_rhs = (copy_expression pc_rhs) - } -and copy_value_binding : - Ast_409.Parsetree.value_binding -> Ast_408.Parsetree.value_binding = - fun - { Ast_409.Parsetree.pvb_pat = pvb_pat; - Ast_409.Parsetree.pvb_expr = pvb_expr; - Ast_409.Parsetree.pvb_attributes = pvb_attributes; - Ast_409.Parsetree.pvb_loc = pvb_loc } - -> - { - Ast_408.Parsetree.pvb_pat = (copy_pattern pvb_pat); - Ast_408.Parsetree.pvb_expr = (copy_expression pvb_expr); - Ast_408.Parsetree.pvb_attributes = (copy_attributes pvb_attributes); - Ast_408.Parsetree.pvb_loc = (copy_location pvb_loc) - } -and copy_pattern : Ast_409.Parsetree.pattern -> Ast_408.Parsetree.pattern = - fun - { Ast_409.Parsetree.ppat_desc = ppat_desc; - Ast_409.Parsetree.ppat_loc = ppat_loc; - Ast_409.Parsetree.ppat_loc_stack = ppat_loc_stack; - Ast_409.Parsetree.ppat_attributes = ppat_attributes } - -> - { - Ast_408.Parsetree.ppat_desc = (copy_pattern_desc ppat_desc); - Ast_408.Parsetree.ppat_loc = (copy_location ppat_loc); - Ast_408.Parsetree.ppat_loc_stack = - (List.map copy_location ppat_loc_stack); - Ast_408.Parsetree.ppat_attributes = (copy_attributes ppat_attributes) - } -and copy_pattern_desc : - Ast_409.Parsetree.pattern_desc -> Ast_408.Parsetree.pattern_desc = - function - | Ast_409.Parsetree.Ppat_any -> Ast_408.Parsetree.Ppat_any - | Ast_409.Parsetree.Ppat_var x0 -> - Ast_408.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | Ast_409.Parsetree.Ppat_alias (x0, x1) -> - Ast_408.Parsetree.Ppat_alias - ((copy_pattern x0), (copy_loc (fun x -> x) x1)) - | Ast_409.Parsetree.Ppat_constant x0 -> - Ast_408.Parsetree.Ppat_constant (copy_constant x0) - | Ast_409.Parsetree.Ppat_interval (x0, x1) -> - Ast_408.Parsetree.Ppat_interval - ((copy_constant x0), (copy_constant x1)) - | Ast_409.Parsetree.Ppat_tuple x0 -> - Ast_408.Parsetree.Ppat_tuple (List.map copy_pattern x0) - | Ast_409.Parsetree.Ppat_construct (x0, x1) -> - Ast_408.Parsetree.Ppat_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_pattern x1)) - | Ast_409.Parsetree.Ppat_variant (x0, x1) -> - Ast_408.Parsetree.Ppat_variant - ((copy_label x0), (Option.map copy_pattern x1)) - | Ast_409.Parsetree.Ppat_record (x0, x1) -> - Ast_408.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | Ast_409.Parsetree.Ppat_array x0 -> - Ast_408.Parsetree.Ppat_array (List.map copy_pattern x0) - | Ast_409.Parsetree.Ppat_or (x0, x1) -> - Ast_408.Parsetree.Ppat_or ((copy_pattern x0), (copy_pattern x1)) - | Ast_409.Parsetree.Ppat_constraint (x0, x1) -> - Ast_408.Parsetree.Ppat_constraint - ((copy_pattern x0), (copy_core_type x1)) - | Ast_409.Parsetree.Ppat_type x0 -> - Ast_408.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) - | Ast_409.Parsetree.Ppat_lazy x0 -> - Ast_408.Parsetree.Ppat_lazy (copy_pattern x0) - | Ast_409.Parsetree.Ppat_unpack x0 -> - Ast_408.Parsetree.Ppat_unpack (copy_loc (fun x -> x) x0) - | Ast_409.Parsetree.Ppat_exception x0 -> - Ast_408.Parsetree.Ppat_exception (copy_pattern x0) - | Ast_409.Parsetree.Ppat_extension x0 -> - Ast_408.Parsetree.Ppat_extension (copy_extension x0) - | Ast_409.Parsetree.Ppat_open (x0, x1) -> - Ast_408.Parsetree.Ppat_open - ((copy_loc copy_Longident_t x0), (copy_pattern x1)) -and copy_core_type : - Ast_409.Parsetree.core_type -> Ast_408.Parsetree.core_type = - fun - { Ast_409.Parsetree.ptyp_desc = ptyp_desc; - Ast_409.Parsetree.ptyp_loc = ptyp_loc; - Ast_409.Parsetree.ptyp_loc_stack = ptyp_loc_stack; - Ast_409.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - Ast_408.Parsetree.ptyp_desc = (copy_core_type_desc ptyp_desc); - Ast_408.Parsetree.ptyp_loc = (copy_location ptyp_loc); - Ast_408.Parsetree.ptyp_loc_stack = - (List.map copy_location ptyp_loc_stack); - Ast_408.Parsetree.ptyp_attributes = (copy_attributes ptyp_attributes) - } -and copy_core_type_desc : - Ast_409.Parsetree.core_type_desc -> Ast_408.Parsetree.core_type_desc = - function - | Ast_409.Parsetree.Ptyp_any -> Ast_408.Parsetree.Ptyp_any - | Ast_409.Parsetree.Ptyp_var x0 -> Ast_408.Parsetree.Ptyp_var x0 - | Ast_409.Parsetree.Ptyp_arrow (x0, x1, x2) -> - Ast_408.Parsetree.Ptyp_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_core_type x2)) - | Ast_409.Parsetree.Ptyp_tuple x0 -> - Ast_408.Parsetree.Ptyp_tuple (List.map copy_core_type x0) - | Ast_409.Parsetree.Ptyp_constr (x0, x1) -> - Ast_408.Parsetree.Ptyp_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_409.Parsetree.Ptyp_object (x0, x1) -> - Ast_408.Parsetree.Ptyp_object - ((List.map copy_object_field x0), (copy_closed_flag x1)) - | Ast_409.Parsetree.Ptyp_class (x0, x1) -> - Ast_408.Parsetree.Ptyp_class - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_409.Parsetree.Ptyp_alias (x0, x1) -> - Ast_408.Parsetree.Ptyp_alias ((copy_core_type x0), x1) - | Ast_409.Parsetree.Ptyp_variant (x0, x1, x2) -> - Ast_408.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), (copy_closed_flag x1), - (Option.map (fun x -> List.map copy_label x) x2)) - | Ast_409.Parsetree.Ptyp_poly (x0, x1) -> - Ast_408.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | Ast_409.Parsetree.Ptyp_package x0 -> - Ast_408.Parsetree.Ptyp_package (copy_package_type x0) - | Ast_409.Parsetree.Ptyp_extension x0 -> - Ast_408.Parsetree.Ptyp_extension (copy_extension x0) -and copy_package_type : - Ast_409.Parsetree.package_type -> Ast_408.Parsetree.package_type = - fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_core_type x1))) x1)) -and copy_row_field : - Ast_409.Parsetree.row_field -> Ast_408.Parsetree.row_field = - fun - { Ast_409.Parsetree.prf_desc = prf_desc; - Ast_409.Parsetree.prf_loc = prf_loc; - Ast_409.Parsetree.prf_attributes = prf_attributes } - -> - { - Ast_408.Parsetree.prf_desc = (copy_row_field_desc prf_desc); - Ast_408.Parsetree.prf_loc = (copy_location prf_loc); - Ast_408.Parsetree.prf_attributes = (copy_attributes prf_attributes) - } -and copy_row_field_desc : - Ast_409.Parsetree.row_field_desc -> Ast_408.Parsetree.row_field_desc = - function - | Ast_409.Parsetree.Rtag (x0, x1, x2) -> - Ast_408.Parsetree.Rtag - ((copy_loc copy_label x0), x1, (List.map copy_core_type x2)) - | Ast_409.Parsetree.Rinherit x0 -> - Ast_408.Parsetree.Rinherit (copy_core_type x0) -and copy_object_field : - Ast_409.Parsetree.object_field -> Ast_408.Parsetree.object_field = - fun - { Ast_409.Parsetree.pof_desc = pof_desc; - Ast_409.Parsetree.pof_loc = pof_loc; - Ast_409.Parsetree.pof_attributes = pof_attributes } - -> - { - Ast_408.Parsetree.pof_desc = (copy_object_field_desc pof_desc); - Ast_408.Parsetree.pof_loc = (copy_location pof_loc); - Ast_408.Parsetree.pof_attributes = (copy_attributes pof_attributes) - } -and copy_attributes : - Ast_409.Parsetree.attributes -> Ast_408.Parsetree.attributes = - fun x -> List.map copy_attribute x -and copy_attribute : - Ast_409.Parsetree.attribute -> Ast_408.Parsetree.attribute = - fun - { Ast_409.Parsetree.attr_name = attr_name; - Ast_409.Parsetree.attr_payload = attr_payload; - Ast_409.Parsetree.attr_loc = attr_loc } - -> - { - Ast_408.Parsetree.attr_name = (copy_loc (fun x -> x) attr_name); - Ast_408.Parsetree.attr_payload = (copy_payload attr_payload); - Ast_408.Parsetree.attr_loc = (copy_location attr_loc) - } -and copy_payload : Ast_409.Parsetree.payload -> Ast_408.Parsetree.payload = - function - | Ast_409.Parsetree.PStr x0 -> Ast_408.Parsetree.PStr (copy_structure x0) - | Ast_409.Parsetree.PSig x0 -> Ast_408.Parsetree.PSig (copy_signature x0) - | Ast_409.Parsetree.PTyp x0 -> Ast_408.Parsetree.PTyp (copy_core_type x0) - | Ast_409.Parsetree.PPat (x0, x1) -> - Ast_408.Parsetree.PPat - ((copy_pattern x0), (Option.map copy_expression x1)) -and copy_structure : - Ast_409.Parsetree.structure -> Ast_408.Parsetree.structure = - fun x -> List.map copy_structure_item x -and copy_structure_item : - Ast_409.Parsetree.structure_item -> Ast_408.Parsetree.structure_item = - fun - { Ast_409.Parsetree.pstr_desc = pstr_desc; - Ast_409.Parsetree.pstr_loc = pstr_loc } - -> - { - Ast_408.Parsetree.pstr_desc = (copy_structure_item_desc pstr_desc); - Ast_408.Parsetree.pstr_loc = (copy_location pstr_loc) - } -and copy_structure_item_desc : - Ast_409.Parsetree.structure_item_desc -> - Ast_408.Parsetree.structure_item_desc - = - function - | Ast_409.Parsetree.Pstr_eval (x0, x1) -> - Ast_408.Parsetree.Pstr_eval - ((copy_expression x0), (copy_attributes x1)) - | Ast_409.Parsetree.Pstr_value (x0, x1) -> - Ast_408.Parsetree.Pstr_value - ((copy_rec_flag x0), (List.map copy_value_binding x1)) - | Ast_409.Parsetree.Pstr_primitive x0 -> - Ast_408.Parsetree.Pstr_primitive (copy_value_description x0) - | Ast_409.Parsetree.Pstr_type (x0, x1) -> - Ast_408.Parsetree.Pstr_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_409.Parsetree.Pstr_typext x0 -> - Ast_408.Parsetree.Pstr_typext (copy_type_extension x0) - | Ast_409.Parsetree.Pstr_exception x0 -> - Ast_408.Parsetree.Pstr_exception (copy_type_exception x0) - | Ast_409.Parsetree.Pstr_module x0 -> - Ast_408.Parsetree.Pstr_module (copy_module_binding x0) - | Ast_409.Parsetree.Pstr_recmodule x0 -> - Ast_408.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) - | Ast_409.Parsetree.Pstr_modtype x0 -> - Ast_408.Parsetree.Pstr_modtype (copy_module_type_declaration x0) - | Ast_409.Parsetree.Pstr_open x0 -> - Ast_408.Parsetree.Pstr_open (copy_open_declaration x0) - | Ast_409.Parsetree.Pstr_class x0 -> - Ast_408.Parsetree.Pstr_class (List.map copy_class_declaration x0) - | Ast_409.Parsetree.Pstr_class_type x0 -> - Ast_408.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | Ast_409.Parsetree.Pstr_include x0 -> - Ast_408.Parsetree.Pstr_include (copy_include_declaration x0) - | Ast_409.Parsetree.Pstr_attribute x0 -> - Ast_408.Parsetree.Pstr_attribute (copy_attribute x0) - | Ast_409.Parsetree.Pstr_extension (x0, x1) -> - Ast_408.Parsetree.Pstr_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_include_declaration : - Ast_409.Parsetree.include_declaration -> - Ast_408.Parsetree.include_declaration - = fun x -> copy_include_infos copy_module_expr x -and copy_class_declaration : - Ast_409.Parsetree.class_declaration -> Ast_408.Parsetree.class_declaration - = fun x -> copy_class_infos copy_class_expr x -and copy_class_expr : - Ast_409.Parsetree.class_expr -> Ast_408.Parsetree.class_expr = - fun - { Ast_409.Parsetree.pcl_desc = pcl_desc; - Ast_409.Parsetree.pcl_loc = pcl_loc; - Ast_409.Parsetree.pcl_attributes = pcl_attributes } - -> - { - Ast_408.Parsetree.pcl_desc = (copy_class_expr_desc pcl_desc); - Ast_408.Parsetree.pcl_loc = (copy_location pcl_loc); - Ast_408.Parsetree.pcl_attributes = (copy_attributes pcl_attributes) - } -and copy_class_expr_desc : - Ast_409.Parsetree.class_expr_desc -> Ast_408.Parsetree.class_expr_desc = - function - | Ast_409.Parsetree.Pcl_constr (x0, x1) -> - Ast_408.Parsetree.Pcl_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_409.Parsetree.Pcl_structure x0 -> - Ast_408.Parsetree.Pcl_structure (copy_class_structure x0) - | Ast_409.Parsetree.Pcl_fun (x0, x1, x2, x3) -> - Ast_408.Parsetree.Pcl_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_class_expr x3)) - | Ast_409.Parsetree.Pcl_apply (x0, x1) -> - Ast_408.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_409.Parsetree.Pcl_let (x0, x1, x2) -> - Ast_408.Parsetree.Pcl_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_class_expr x2)) - | Ast_409.Parsetree.Pcl_constraint (x0, x1) -> - Ast_408.Parsetree.Pcl_constraint - ((copy_class_expr x0), (copy_class_type x1)) - | Ast_409.Parsetree.Pcl_extension x0 -> - Ast_408.Parsetree.Pcl_extension (copy_extension x0) - | Ast_409.Parsetree.Pcl_open (x0, x1) -> - Ast_408.Parsetree.Pcl_open - ((copy_open_description x0), (copy_class_expr x1)) -and copy_class_structure : - Ast_409.Parsetree.class_structure -> Ast_408.Parsetree.class_structure = - fun - { Ast_409.Parsetree.pcstr_self = pcstr_self; - Ast_409.Parsetree.pcstr_fields = pcstr_fields } - -> - { - Ast_408.Parsetree.pcstr_self = (copy_pattern pcstr_self); - Ast_408.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } -and copy_class_field : - Ast_409.Parsetree.class_field -> Ast_408.Parsetree.class_field = - fun - { Ast_409.Parsetree.pcf_desc = pcf_desc; - Ast_409.Parsetree.pcf_loc = pcf_loc; - Ast_409.Parsetree.pcf_attributes = pcf_attributes } - -> - { - Ast_408.Parsetree.pcf_desc = (copy_class_field_desc pcf_desc); - Ast_408.Parsetree.pcf_loc = (copy_location pcf_loc); - Ast_408.Parsetree.pcf_attributes = (copy_attributes pcf_attributes) - } -and copy_class_field_desc : - Ast_409.Parsetree.class_field_desc -> Ast_408.Parsetree.class_field_desc = - function - | Ast_409.Parsetree.Pcf_inherit (x0, x1, x2) -> - Ast_408.Parsetree.Pcf_inherit - ((copy_override_flag x0), (copy_class_expr x1), - (Option.map (fun x -> copy_loc (fun x -> x) x) x2)) - | Ast_409.Parsetree.Pcf_val x0 -> - Ast_408.Parsetree.Pcf_val - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | Ast_409.Parsetree.Pcf_method x0 -> - Ast_408.Parsetree.Pcf_method - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_class_field_kind x2))) - | Ast_409.Parsetree.Pcf_constraint x0 -> - Ast_408.Parsetree.Pcf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_409.Parsetree.Pcf_initializer x0 -> - Ast_408.Parsetree.Pcf_initializer (copy_expression x0) - | Ast_409.Parsetree.Pcf_attribute x0 -> - Ast_408.Parsetree.Pcf_attribute (copy_attribute x0) - | Ast_409.Parsetree.Pcf_extension x0 -> - Ast_408.Parsetree.Pcf_extension (copy_extension x0) -and copy_class_field_kind : - Ast_409.Parsetree.class_field_kind -> Ast_408.Parsetree.class_field_kind = - function - | Ast_409.Parsetree.Cfk_virtual x0 -> - Ast_408.Parsetree.Cfk_virtual (copy_core_type x0) - | Ast_409.Parsetree.Cfk_concrete (x0, x1) -> - Ast_408.Parsetree.Cfk_concrete - ((copy_override_flag x0), (copy_expression x1)) -and copy_open_declaration : - Ast_409.Parsetree.open_declaration -> Ast_408.Parsetree.open_declaration = - fun x -> copy_open_infos copy_module_expr x -and copy_module_binding : - Ast_409.Parsetree.module_binding -> Ast_408.Parsetree.module_binding = - fun - { Ast_409.Parsetree.pmb_name = pmb_name; - Ast_409.Parsetree.pmb_expr = pmb_expr; - Ast_409.Parsetree.pmb_attributes = pmb_attributes; - Ast_409.Parsetree.pmb_loc = pmb_loc } - -> - { - Ast_408.Parsetree.pmb_name = (copy_loc (fun x -> x) pmb_name); - Ast_408.Parsetree.pmb_expr = (copy_module_expr pmb_expr); - Ast_408.Parsetree.pmb_attributes = (copy_attributes pmb_attributes); - Ast_408.Parsetree.pmb_loc = (copy_location pmb_loc) - } -and copy_module_expr : - Ast_409.Parsetree.module_expr -> Ast_408.Parsetree.module_expr = - fun - { Ast_409.Parsetree.pmod_desc = pmod_desc; - Ast_409.Parsetree.pmod_loc = pmod_loc; - Ast_409.Parsetree.pmod_attributes = pmod_attributes } - -> - { - Ast_408.Parsetree.pmod_desc = (copy_module_expr_desc pmod_desc); - Ast_408.Parsetree.pmod_loc = (copy_location pmod_loc); - Ast_408.Parsetree.pmod_attributes = (copy_attributes pmod_attributes) - } -and copy_module_expr_desc : - Ast_409.Parsetree.module_expr_desc -> Ast_408.Parsetree.module_expr_desc = - function - | Ast_409.Parsetree.Pmod_ident x0 -> - Ast_408.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) - | Ast_409.Parsetree.Pmod_structure x0 -> - Ast_408.Parsetree.Pmod_structure (copy_structure x0) - | Ast_409.Parsetree.Pmod_functor (x0, x1, x2) -> - Ast_408.Parsetree.Pmod_functor - ((copy_loc (fun x -> x) x0), (Option.map copy_module_type x1), - (copy_module_expr x2)) - | Ast_409.Parsetree.Pmod_apply (x0, x1) -> - Ast_408.Parsetree.Pmod_apply - ((copy_module_expr x0), (copy_module_expr x1)) - | Ast_409.Parsetree.Pmod_constraint (x0, x1) -> - Ast_408.Parsetree.Pmod_constraint - ((copy_module_expr x0), (copy_module_type x1)) - | Ast_409.Parsetree.Pmod_unpack x0 -> - Ast_408.Parsetree.Pmod_unpack (copy_expression x0) - | Ast_409.Parsetree.Pmod_extension x0 -> - Ast_408.Parsetree.Pmod_extension (copy_extension x0) -and copy_module_type : - Ast_409.Parsetree.module_type -> Ast_408.Parsetree.module_type = - fun - { Ast_409.Parsetree.pmty_desc = pmty_desc; - Ast_409.Parsetree.pmty_loc = pmty_loc; - Ast_409.Parsetree.pmty_attributes = pmty_attributes } - -> - { - Ast_408.Parsetree.pmty_desc = (copy_module_type_desc pmty_desc); - Ast_408.Parsetree.pmty_loc = (copy_location pmty_loc); - Ast_408.Parsetree.pmty_attributes = (copy_attributes pmty_attributes) - } -and copy_module_type_desc : - Ast_409.Parsetree.module_type_desc -> Ast_408.Parsetree.module_type_desc = - function - | Ast_409.Parsetree.Pmty_ident x0 -> - Ast_408.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) - | Ast_409.Parsetree.Pmty_signature x0 -> - Ast_408.Parsetree.Pmty_signature (copy_signature x0) - | Ast_409.Parsetree.Pmty_functor (x0, x1, x2) -> - Ast_408.Parsetree.Pmty_functor - ((copy_loc (fun x -> x) x0), (Option.map copy_module_type x1), - (copy_module_type x2)) - | Ast_409.Parsetree.Pmty_with (x0, x1) -> - Ast_408.Parsetree.Pmty_with - ((copy_module_type x0), (List.map copy_with_constraint x1)) - | Ast_409.Parsetree.Pmty_typeof x0 -> - Ast_408.Parsetree.Pmty_typeof (copy_module_expr x0) - | Ast_409.Parsetree.Pmty_extension x0 -> - Ast_408.Parsetree.Pmty_extension (copy_extension x0) - | Ast_409.Parsetree.Pmty_alias x0 -> - Ast_408.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) -and copy_with_constraint : - Ast_409.Parsetree.with_constraint -> Ast_408.Parsetree.with_constraint = - function - | Ast_409.Parsetree.Pwith_type (x0, x1) -> - Ast_408.Parsetree.Pwith_type - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_409.Parsetree.Pwith_module (x0, x1) -> - Ast_408.Parsetree.Pwith_module - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) - | Ast_409.Parsetree.Pwith_typesubst (x0, x1) -> - Ast_408.Parsetree.Pwith_typesubst - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_409.Parsetree.Pwith_modsubst (x0, x1) -> - Ast_408.Parsetree.Pwith_modsubst - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) -and copy_signature : - Ast_409.Parsetree.signature -> Ast_408.Parsetree.signature = - fun x -> List.map copy_signature_item x -and copy_signature_item : - Ast_409.Parsetree.signature_item -> Ast_408.Parsetree.signature_item = - fun - { Ast_409.Parsetree.psig_desc = psig_desc; - Ast_409.Parsetree.psig_loc = psig_loc } - -> - { - Ast_408.Parsetree.psig_desc = (copy_signature_item_desc psig_desc); - Ast_408.Parsetree.psig_loc = (copy_location psig_loc) - } -and copy_signature_item_desc : - Ast_409.Parsetree.signature_item_desc -> - Ast_408.Parsetree.signature_item_desc - = - function - | Ast_409.Parsetree.Psig_value x0 -> - Ast_408.Parsetree.Psig_value (copy_value_description x0) - | Ast_409.Parsetree.Psig_type (x0, x1) -> - Ast_408.Parsetree.Psig_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_409.Parsetree.Psig_typesubst x0 -> - Ast_408.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) - | Ast_409.Parsetree.Psig_typext x0 -> - Ast_408.Parsetree.Psig_typext (copy_type_extension x0) - | Ast_409.Parsetree.Psig_exception x0 -> - Ast_408.Parsetree.Psig_exception (copy_type_exception x0) - | Ast_409.Parsetree.Psig_module x0 -> - Ast_408.Parsetree.Psig_module (copy_module_declaration x0) - | Ast_409.Parsetree.Psig_modsubst x0 -> - Ast_408.Parsetree.Psig_modsubst (copy_module_substitution x0) - | Ast_409.Parsetree.Psig_recmodule x0 -> - Ast_408.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) - | Ast_409.Parsetree.Psig_modtype x0 -> - Ast_408.Parsetree.Psig_modtype (copy_module_type_declaration x0) - | Ast_409.Parsetree.Psig_open x0 -> - Ast_408.Parsetree.Psig_open (copy_open_description x0) - | Ast_409.Parsetree.Psig_include x0 -> - Ast_408.Parsetree.Psig_include (copy_include_description x0) - | Ast_409.Parsetree.Psig_class x0 -> - Ast_408.Parsetree.Psig_class (List.map copy_class_description x0) - | Ast_409.Parsetree.Psig_class_type x0 -> - Ast_408.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | Ast_409.Parsetree.Psig_attribute x0 -> - Ast_408.Parsetree.Psig_attribute (copy_attribute x0) - | Ast_409.Parsetree.Psig_extension (x0, x1) -> - Ast_408.Parsetree.Psig_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_class_type_declaration : - Ast_409.Parsetree.class_type_declaration -> - Ast_408.Parsetree.class_type_declaration - = fun x -> copy_class_infos copy_class_type x -and copy_class_description : - Ast_409.Parsetree.class_description -> Ast_408.Parsetree.class_description - = fun x -> copy_class_infos copy_class_type x -and copy_class_type : - Ast_409.Parsetree.class_type -> Ast_408.Parsetree.class_type = - fun - { Ast_409.Parsetree.pcty_desc = pcty_desc; - Ast_409.Parsetree.pcty_loc = pcty_loc; - Ast_409.Parsetree.pcty_attributes = pcty_attributes } - -> - { - Ast_408.Parsetree.pcty_desc = (copy_class_type_desc pcty_desc); - Ast_408.Parsetree.pcty_loc = (copy_location pcty_loc); - Ast_408.Parsetree.pcty_attributes = (copy_attributes pcty_attributes) - } -and copy_class_type_desc : - Ast_409.Parsetree.class_type_desc -> Ast_408.Parsetree.class_type_desc = - function - | Ast_409.Parsetree.Pcty_constr (x0, x1) -> - Ast_408.Parsetree.Pcty_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_409.Parsetree.Pcty_signature x0 -> - Ast_408.Parsetree.Pcty_signature (copy_class_signature x0) - | Ast_409.Parsetree.Pcty_arrow (x0, x1, x2) -> - Ast_408.Parsetree.Pcty_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_class_type x2)) - | Ast_409.Parsetree.Pcty_extension x0 -> - Ast_408.Parsetree.Pcty_extension (copy_extension x0) - | Ast_409.Parsetree.Pcty_open (x0, x1) -> - Ast_408.Parsetree.Pcty_open - ((copy_open_description x0), (copy_class_type x1)) -and copy_class_signature : - Ast_409.Parsetree.class_signature -> Ast_408.Parsetree.class_signature = - fun - { Ast_409.Parsetree.pcsig_self = pcsig_self; - Ast_409.Parsetree.pcsig_fields = pcsig_fields } - -> - { - Ast_408.Parsetree.pcsig_self = (copy_core_type pcsig_self); - Ast_408.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } -and copy_class_type_field : - Ast_409.Parsetree.class_type_field -> Ast_408.Parsetree.class_type_field = - fun - { Ast_409.Parsetree.pctf_desc = pctf_desc; - Ast_409.Parsetree.pctf_loc = pctf_loc; - Ast_409.Parsetree.pctf_attributes = pctf_attributes } - -> - { - Ast_408.Parsetree.pctf_desc = (copy_class_type_field_desc pctf_desc); - Ast_408.Parsetree.pctf_loc = (copy_location pctf_loc); - Ast_408.Parsetree.pctf_attributes = (copy_attributes pctf_attributes) - } -and copy_class_type_field_desc : - Ast_409.Parsetree.class_type_field_desc -> - Ast_408.Parsetree.class_type_field_desc - = - function - | Ast_409.Parsetree.Pctf_inherit x0 -> - Ast_408.Parsetree.Pctf_inherit (copy_class_type x0) - | Ast_409.Parsetree.Pctf_val x0 -> - Ast_408.Parsetree.Pctf_val - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_409.Parsetree.Pctf_method x0 -> - Ast_408.Parsetree.Pctf_method - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_409.Parsetree.Pctf_constraint x0 -> - Ast_408.Parsetree.Pctf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_409.Parsetree.Pctf_attribute x0 -> - Ast_408.Parsetree.Pctf_attribute (copy_attribute x0) - | Ast_409.Parsetree.Pctf_extension x0 -> - Ast_408.Parsetree.Pctf_extension (copy_extension x0) -and copy_extension : - Ast_409.Parsetree.extension -> Ast_408.Parsetree.extension = - fun x -> - let (x0, x1) = x in ((copy_loc (fun x -> x) x0), (copy_payload x1)) -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_409.Parsetree.class_infos -> 'g0 Ast_408.Parsetree.class_infos - = - fun f0 -> - fun - { Ast_409.Parsetree.pci_virt = pci_virt; - Ast_409.Parsetree.pci_params = pci_params; - Ast_409.Parsetree.pci_name = pci_name; - Ast_409.Parsetree.pci_expr = pci_expr; - Ast_409.Parsetree.pci_loc = pci_loc; - Ast_409.Parsetree.pci_attributes = pci_attributes } - -> - { - Ast_408.Parsetree.pci_virt = (copy_virtual_flag pci_virt); - Ast_408.Parsetree.pci_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - pci_params); - Ast_408.Parsetree.pci_name = (copy_loc (fun x -> x) pci_name); - Ast_408.Parsetree.pci_expr = (f0 pci_expr); - Ast_408.Parsetree.pci_loc = (copy_location pci_loc); - Ast_408.Parsetree.pci_attributes = (copy_attributes pci_attributes) - } -and copy_virtual_flag : - Ast_409.Asttypes.virtual_flag -> Ast_408.Asttypes.virtual_flag = - function - | Ast_409.Asttypes.Virtual -> Ast_408.Asttypes.Virtual - | Ast_409.Asttypes.Concrete -> Ast_408.Asttypes.Concrete -and copy_include_description : - Ast_409.Parsetree.include_description -> - Ast_408.Parsetree.include_description - = fun x -> copy_include_infos copy_module_type x -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_409.Parsetree.include_infos -> - 'g0 Ast_408.Parsetree.include_infos - = - fun f0 -> - fun - { Ast_409.Parsetree.pincl_mod = pincl_mod; - Ast_409.Parsetree.pincl_loc = pincl_loc; - Ast_409.Parsetree.pincl_attributes = pincl_attributes } - -> - { - Ast_408.Parsetree.pincl_mod = (f0 pincl_mod); - Ast_408.Parsetree.pincl_loc = (copy_location pincl_loc); - Ast_408.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } -and copy_open_description : - Ast_409.Parsetree.open_description -> Ast_408.Parsetree.open_description = - fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x -and copy_open_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_409.Parsetree.open_infos -> 'g0 Ast_408.Parsetree.open_infos - = - fun f0 -> - fun - { Ast_409.Parsetree.popen_expr = popen_expr; - Ast_409.Parsetree.popen_override = popen_override; - Ast_409.Parsetree.popen_loc = popen_loc; - Ast_409.Parsetree.popen_attributes = popen_attributes } - -> - { - Ast_408.Parsetree.popen_expr = (f0 popen_expr); - Ast_408.Parsetree.popen_override = - (copy_override_flag popen_override); - Ast_408.Parsetree.popen_loc = (copy_location popen_loc); - Ast_408.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } -and copy_override_flag : - Ast_409.Asttypes.override_flag -> Ast_408.Asttypes.override_flag = - function - | Ast_409.Asttypes.Override -> Ast_408.Asttypes.Override - | Ast_409.Asttypes.Fresh -> Ast_408.Asttypes.Fresh -and copy_module_type_declaration : - Ast_409.Parsetree.module_type_declaration -> - Ast_408.Parsetree.module_type_declaration - = - fun - { Ast_409.Parsetree.pmtd_name = pmtd_name; - Ast_409.Parsetree.pmtd_type = pmtd_type; - Ast_409.Parsetree.pmtd_attributes = pmtd_attributes; - Ast_409.Parsetree.pmtd_loc = pmtd_loc } - -> - { - Ast_408.Parsetree.pmtd_name = (copy_loc (fun x -> x) pmtd_name); - Ast_408.Parsetree.pmtd_type = (Option.map copy_module_type pmtd_type); - Ast_408.Parsetree.pmtd_attributes = (copy_attributes pmtd_attributes); - Ast_408.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } -and copy_module_substitution : - Ast_409.Parsetree.module_substitution -> - Ast_408.Parsetree.module_substitution - = - fun - { Ast_409.Parsetree.pms_name = pms_name; - Ast_409.Parsetree.pms_manifest = pms_manifest; - Ast_409.Parsetree.pms_attributes = pms_attributes; - Ast_409.Parsetree.pms_loc = pms_loc } - -> - { - Ast_408.Parsetree.pms_name = (copy_loc (fun x -> x) pms_name); - Ast_408.Parsetree.pms_manifest = - (copy_loc copy_Longident_t pms_manifest); - Ast_408.Parsetree.pms_attributes = (copy_attributes pms_attributes); - Ast_408.Parsetree.pms_loc = (copy_location pms_loc) - } -and copy_module_declaration : - Ast_409.Parsetree.module_declaration -> - Ast_408.Parsetree.module_declaration - = - fun - { Ast_409.Parsetree.pmd_name = pmd_name; - Ast_409.Parsetree.pmd_type = pmd_type; - Ast_409.Parsetree.pmd_attributes = pmd_attributes; - Ast_409.Parsetree.pmd_loc = pmd_loc } - -> - { - Ast_408.Parsetree.pmd_name = (copy_loc (fun x -> x) pmd_name); - Ast_408.Parsetree.pmd_type = (copy_module_type pmd_type); - Ast_408.Parsetree.pmd_attributes = (copy_attributes pmd_attributes); - Ast_408.Parsetree.pmd_loc = (copy_location pmd_loc) - } -and copy_type_exception : - Ast_409.Parsetree.type_exception -> Ast_408.Parsetree.type_exception = - fun - { Ast_409.Parsetree.ptyexn_constructor = ptyexn_constructor; - Ast_409.Parsetree.ptyexn_loc = ptyexn_loc; - Ast_409.Parsetree.ptyexn_attributes = ptyexn_attributes } - -> - { - Ast_408.Parsetree.ptyexn_constructor = - (copy_extension_constructor ptyexn_constructor); - Ast_408.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); - Ast_408.Parsetree.ptyexn_attributes = - (copy_attributes ptyexn_attributes) - } -and copy_type_extension : - Ast_409.Parsetree.type_extension -> Ast_408.Parsetree.type_extension = - fun - { Ast_409.Parsetree.ptyext_path = ptyext_path; - Ast_409.Parsetree.ptyext_params = ptyext_params; - Ast_409.Parsetree.ptyext_constructors = ptyext_constructors; - Ast_409.Parsetree.ptyext_private = ptyext_private; - Ast_409.Parsetree.ptyext_loc = ptyext_loc; - Ast_409.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - Ast_408.Parsetree.ptyext_path = (copy_loc copy_Longident_t ptyext_path); - Ast_408.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - ptyext_params); - Ast_408.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor ptyext_constructors); - Ast_408.Parsetree.ptyext_private = (copy_private_flag ptyext_private); - Ast_408.Parsetree.ptyext_loc = (copy_location ptyext_loc); - Ast_408.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } -and copy_extension_constructor : - Ast_409.Parsetree.extension_constructor -> - Ast_408.Parsetree.extension_constructor - = - fun - { Ast_409.Parsetree.pext_name = pext_name; - Ast_409.Parsetree.pext_kind = pext_kind; - Ast_409.Parsetree.pext_loc = pext_loc; - Ast_409.Parsetree.pext_attributes = pext_attributes } - -> - { - Ast_408.Parsetree.pext_name = (copy_loc (fun x -> x) pext_name); - Ast_408.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - Ast_408.Parsetree.pext_loc = (copy_location pext_loc); - Ast_408.Parsetree.pext_attributes = (copy_attributes pext_attributes) - } -and copy_extension_constructor_kind : - Ast_409.Parsetree.extension_constructor_kind -> - Ast_408.Parsetree.extension_constructor_kind - = - function - | Ast_409.Parsetree.Pext_decl (x0, x1) -> - Ast_408.Parsetree.Pext_decl - ((copy_constructor_arguments x0), (Option.map copy_core_type x1)) - | Ast_409.Parsetree.Pext_rebind x0 -> - Ast_408.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) -and copy_type_declaration : - Ast_409.Parsetree.type_declaration -> Ast_408.Parsetree.type_declaration = - fun - { Ast_409.Parsetree.ptype_name = ptype_name; - Ast_409.Parsetree.ptype_params = ptype_params; - Ast_409.Parsetree.ptype_cstrs = ptype_cstrs; - Ast_409.Parsetree.ptype_kind = ptype_kind; - Ast_409.Parsetree.ptype_private = ptype_private; - Ast_409.Parsetree.ptype_manifest = ptype_manifest; - Ast_409.Parsetree.ptype_attributes = ptype_attributes; - Ast_409.Parsetree.ptype_loc = ptype_loc } - -> - { - Ast_408.Parsetree.ptype_name = (copy_loc (fun x -> x) ptype_name); - Ast_408.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - ptype_params); - Ast_408.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0, x1, x2) = x in - ((copy_core_type x0), (copy_core_type x1), (copy_location x2))) - ptype_cstrs); - Ast_408.Parsetree.ptype_kind = (copy_type_kind ptype_kind); - Ast_408.Parsetree.ptype_private = (copy_private_flag ptype_private); - Ast_408.Parsetree.ptype_manifest = - (Option.map copy_core_type ptype_manifest); - Ast_408.Parsetree.ptype_attributes = (copy_attributes ptype_attributes); - Ast_408.Parsetree.ptype_loc = (copy_location ptype_loc) - } -and copy_private_flag : - Ast_409.Asttypes.private_flag -> Ast_408.Asttypes.private_flag = - function - | Ast_409.Asttypes.Private -> Ast_408.Asttypes.Private - | Ast_409.Asttypes.Public -> Ast_408.Asttypes.Public -and copy_type_kind : - Ast_409.Parsetree.type_kind -> Ast_408.Parsetree.type_kind = - function - | Ast_409.Parsetree.Ptype_abstract -> Ast_408.Parsetree.Ptype_abstract - | Ast_409.Parsetree.Ptype_variant x0 -> - Ast_408.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | Ast_409.Parsetree.Ptype_record x0 -> - Ast_408.Parsetree.Ptype_record (List.map copy_label_declaration x0) - | Ast_409.Parsetree.Ptype_open -> Ast_408.Parsetree.Ptype_open -and copy_constructor_declaration : - Ast_409.Parsetree.constructor_declaration -> - Ast_408.Parsetree.constructor_declaration - = - fun - { Ast_409.Parsetree.pcd_name = pcd_name; - Ast_409.Parsetree.pcd_args = pcd_args; - Ast_409.Parsetree.pcd_res = pcd_res; - Ast_409.Parsetree.pcd_loc = pcd_loc; - Ast_409.Parsetree.pcd_attributes = pcd_attributes } - -> - { - Ast_408.Parsetree.pcd_name = (copy_loc (fun x -> x) pcd_name); - Ast_408.Parsetree.pcd_args = (copy_constructor_arguments pcd_args); - Ast_408.Parsetree.pcd_res = (Option.map copy_core_type pcd_res); - Ast_408.Parsetree.pcd_loc = (copy_location pcd_loc); - Ast_408.Parsetree.pcd_attributes = (copy_attributes pcd_attributes) - } -and copy_constructor_arguments : - Ast_409.Parsetree.constructor_arguments -> - Ast_408.Parsetree.constructor_arguments - = - function - | Ast_409.Parsetree.Pcstr_tuple x0 -> - Ast_408.Parsetree.Pcstr_tuple (List.map copy_core_type x0) - | Ast_409.Parsetree.Pcstr_record x0 -> - Ast_408.Parsetree.Pcstr_record (List.map copy_label_declaration x0) -and copy_label_declaration : - Ast_409.Parsetree.label_declaration -> Ast_408.Parsetree.label_declaration - = - fun - { Ast_409.Parsetree.pld_name = pld_name; - Ast_409.Parsetree.pld_mutable = pld_mutable; - Ast_409.Parsetree.pld_type = pld_type; - Ast_409.Parsetree.pld_loc = pld_loc; - Ast_409.Parsetree.pld_attributes = pld_attributes } - -> - { - Ast_408.Parsetree.pld_name = (copy_loc (fun x -> x) pld_name); - Ast_408.Parsetree.pld_mutable = (copy_mutable_flag pld_mutable); - Ast_408.Parsetree.pld_type = (copy_core_type pld_type); - Ast_408.Parsetree.pld_loc = (copy_location pld_loc); - Ast_408.Parsetree.pld_attributes = (copy_attributes pld_attributes) - } -and copy_mutable_flag : - Ast_409.Asttypes.mutable_flag -> Ast_408.Asttypes.mutable_flag = - function - | Ast_409.Asttypes.Immutable -> Ast_408.Asttypes.Immutable - | Ast_409.Asttypes.Mutable -> Ast_408.Asttypes.Mutable -and copy_variance : Ast_409.Asttypes.variance -> Ast_408.Asttypes.variance = - function - | Ast_409.Asttypes.Covariant -> Ast_408.Asttypes.Covariant - | Ast_409.Asttypes.Contravariant -> Ast_408.Asttypes.Contravariant - | Ast_409.Asttypes.Invariant -> Ast_408.Asttypes.Invariant -and copy_value_description : - Ast_409.Parsetree.value_description -> Ast_408.Parsetree.value_description - = - fun - { Ast_409.Parsetree.pval_name = pval_name; - Ast_409.Parsetree.pval_type = pval_type; - Ast_409.Parsetree.pval_prim = pval_prim; - Ast_409.Parsetree.pval_attributes = pval_attributes; - Ast_409.Parsetree.pval_loc = pval_loc } - -> - { - Ast_408.Parsetree.pval_name = (copy_loc (fun x -> x) pval_name); - Ast_408.Parsetree.pval_type = (copy_core_type pval_type); - Ast_408.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - Ast_408.Parsetree.pval_attributes = (copy_attributes pval_attributes); - Ast_408.Parsetree.pval_loc = (copy_location pval_loc) - } -and copy_object_field_desc : - Ast_409.Parsetree.object_field_desc -> Ast_408.Parsetree.object_field_desc - = - function - | Ast_409.Parsetree.Otag (x0, x1) -> - Ast_408.Parsetree.Otag ((copy_loc copy_label x0), (copy_core_type x1)) - | Ast_409.Parsetree.Oinherit x0 -> - Ast_408.Parsetree.Oinherit (copy_core_type x0) -and copy_arg_label : Ast_409.Asttypes.arg_label -> Ast_408.Asttypes.arg_label - = - function - | Ast_409.Asttypes.Nolabel -> Ast_408.Asttypes.Nolabel - | Ast_409.Asttypes.Labelled x0 -> Ast_408.Asttypes.Labelled x0 - | Ast_409.Asttypes.Optional x0 -> Ast_408.Asttypes.Optional x0 -and copy_closed_flag : - Ast_409.Asttypes.closed_flag -> Ast_408.Asttypes.closed_flag = - function - | Ast_409.Asttypes.Closed -> Ast_408.Asttypes.Closed - | Ast_409.Asttypes.Open -> Ast_408.Asttypes.Open -and copy_label : Ast_409.Asttypes.label -> Ast_408.Asttypes.label = - fun x -> x -and copy_rec_flag : Ast_409.Asttypes.rec_flag -> Ast_408.Asttypes.rec_flag = - function - | Ast_409.Asttypes.Nonrecursive -> Ast_408.Asttypes.Nonrecursive - | Ast_409.Asttypes.Recursive -> Ast_408.Asttypes.Recursive -and copy_constant : Ast_409.Parsetree.constant -> Ast_408.Parsetree.constant - = - function - | Ast_409.Parsetree.Pconst_integer (x0, x1) -> - Ast_408.Parsetree.Pconst_integer (x0, (Option.map (fun x -> x) x1)) - | Ast_409.Parsetree.Pconst_char x0 -> Ast_408.Parsetree.Pconst_char x0 - | Ast_409.Parsetree.Pconst_string (x0, x1) -> - Ast_408.Parsetree.Pconst_string (x0, (Option.map (fun x -> x) x1)) - | Ast_409.Parsetree.Pconst_float (x0, x1) -> - Ast_408.Parsetree.Pconst_float (x0, (Option.map (fun x -> x) x1)) -and copy_Longident_t : Ast_409.Longident.t -> Ast_408.Longident.t = - function - | Ast_409.Longident.Lident x0 -> Ast_408.Longident.Lident x0 - | Ast_409.Longident.Ldot (x0, x1) -> - Ast_408.Longident.Ldot ((copy_Longident_t x0), x1) - | Ast_409.Longident.Lapply (x0, x1) -> - Ast_408.Longident.Lapply ((copy_Longident_t x0), (copy_Longident_t x1)) -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 Ast_409.Asttypes.loc -> 'g0 Ast_408.Asttypes.loc - = - fun f0 -> - fun { Ast_409.Asttypes.txt = txt; Ast_409.Asttypes.loc = loc } -> - { - Ast_408.Asttypes.txt = (f0 txt); - Ast_408.Asttypes.loc = (copy_location loc) - } -and copy_location : Ast_409.Location.t -> Ast_408.Location.t = - fun - { Ast_409.Location.loc_start = loc_start; - Ast_409.Location.loc_end = loc_end; - Ast_409.Location.loc_ghost = loc_ghost } - -> - { - Ast_408.Location.loc_start = (copy_position loc_start); - Ast_408.Location.loc_end = (copy_position loc_end); - Ast_408.Location.loc_ghost = loc_ghost - } -and copy_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum - } diff --git a/src/vendored-omp/src/migrate_parsetree_409_410.ml b/src/vendored-omp/src/migrate_parsetree_409_410.ml index 81006e9c5..846397543 100644 --- a/src/vendored-omp/src/migrate_parsetree_409_410.ml +++ b/src/vendored-omp/src/migrate_parsetree_409_410.ml @@ -14,127 +14,3 @@ (**************************************************************************) include Migrate_parsetree_409_410_migrate - -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload"; - "binding_op"; "module_substitution"; "open_declaration"; "type_exception" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - binding_op; - module_substitution; - open_declaration; - type_exception; - (*$*) - } as mapper) -> - let module Def = Migrate_parsetree_def in - let module R = Migrate_parsetree_410_409_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - binding_op = (fun _ x -> copy_binding_op (binding_op mapper (R.copy_binding_op x))); - module_substitution = (fun _ x -> copy_module_substitution (module_substitution mapper (R.copy_module_substitution x))); - open_declaration = (fun _ x -> copy_open_declaration (open_declaration mapper (R.copy_open_declaration x))); - type_exception = (fun _ x -> copy_type_exception (type_exception mapper (R.copy_type_exception x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_409_410_migrate.ml b/src/vendored-omp/src/migrate_parsetree_409_410_migrate.ml index b4d507d91..69f60450c 100644 --- a/src/vendored-omp/src/migrate_parsetree_409_410_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_409_410_migrate.ml @@ -1,12 +1,9 @@ +open Stdlib0 module From = Ast_409 module To = Ast_410 -let map_option f x = - match x with - | None -> None - | Some x -> Some (f x) let rec copy_out_type_extension : Ast_409.Outcometree.out_type_extension -> - Ast_410.Outcometree.out_type_extension + Ast_410.Outcometree.out_type_extension = fun { Ast_409.Outcometree.otyext_name = otyext_name; @@ -14,18 +11,18 @@ let rec copy_out_type_extension : Ast_409.Outcometree.otyext_constructors = otyext_constructors; Ast_409.Outcometree.otyext_private = otyext_private } -> - { - Ast_410.Outcometree.otyext_name = otyext_name; - Ast_410.Outcometree.otyext_params = - (List.map (fun x -> x) otyext_params); - Ast_410.Outcometree.otyext_constructors = - (List.map - (fun x -> - let (x0, x1, x2) = x in - (x0, (List.map copy_out_type x1), - (map_option copy_out_type x2))) otyext_constructors); - Ast_410.Outcometree.otyext_private = (copy_private_flag otyext_private) - } + { + Ast_410.Outcometree.otyext_name = otyext_name; + Ast_410.Outcometree.otyext_params = + (List.map (fun x -> x) otyext_params); + Ast_410.Outcometree.otyext_constructors = + (List.map + (fun x -> + let (x0, x1, x2) = x in + (x0, (List.map copy_out_type x1), + (Option.map copy_out_type x2))) otyext_constructors); + Ast_410.Outcometree.otyext_private = (copy_private_flag otyext_private) + } and copy_out_phrase : Ast_409.Outcometree.out_phrase -> Ast_410.Outcometree.out_phrase = function @@ -36,7 +33,7 @@ and copy_out_phrase : (List.map (fun x -> let (x0, x1) = x in - ((copy_out_sig_item x0), (map_option copy_out_value x1))) x0) + ((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0) | Ast_409.Outcometree.Ophr_exception x0 -> Ast_410.Outcometree.Ophr_exception (let (x0, x1) = x0 in (x0, (copy_out_value x1))) @@ -46,17 +43,17 @@ and copy_out_sig_item : | Ast_409.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> Ast_410.Outcometree.Osig_class (x0, x1, - (List.map - (fun x -> - let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), - (copy_out_class_type x3), (copy_out_rec_status x4)) + (List.map + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) | Ast_409.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> Ast_410.Outcometree.Osig_class_type (x0, x1, - (List.map - (fun x -> - let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), - (copy_out_class_type x3), (copy_out_rec_status x4)) + (List.map + (fun x -> + let (x0, x1) = x in (x0, (let (x0, x1) = x1 in (x0, x1)))) x2), + (copy_out_class_type x3), (copy_out_rec_status x4)) | Ast_409.Outcometree.Osig_typext (x0, x1) -> Ast_410.Outcometree.Osig_typext ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) @@ -79,13 +76,13 @@ and copy_out_val_decl : Ast_409.Outcometree.oval_prims = oval_prims; Ast_409.Outcometree.oval_attributes = oval_attributes } -> - { - Ast_410.Outcometree.oval_name = oval_name; - Ast_410.Outcometree.oval_type = (copy_out_type oval_type); - Ast_410.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); - Ast_410.Outcometree.oval_attributes = - (List.map copy_out_attribute oval_attributes) - } + { + Ast_410.Outcometree.oval_name = oval_name; + Ast_410.Outcometree.oval_type = (copy_out_type oval_type); + Ast_410.Outcometree.oval_prims = (List.map (fun x -> x) oval_prims); + Ast_410.Outcometree.oval_attributes = + (List.map copy_out_attribute oval_attributes) + } and copy_out_type_decl : Ast_409.Outcometree.out_type_decl -> Ast_410.Outcometree.out_type_decl = fun @@ -141,7 +138,7 @@ and copy_out_ext_status : | Ast_409.Outcometree.Oext_exception -> Ast_410.Outcometree.Oext_exception and copy_out_extension_constructor : Ast_409.Outcometree.out_extension_constructor -> - Ast_410.Outcometree.out_extension_constructor + Ast_410.Outcometree.out_extension_constructor = fun { Ast_409.Outcometree.oext_name = oext_name; @@ -151,16 +148,21 @@ and copy_out_extension_constructor : Ast_409.Outcometree.oext_ret_type = oext_ret_type; Ast_409.Outcometree.oext_private = oext_private } -> - { - Ast_410.Outcometree.oext_name = oext_name; - Ast_410.Outcometree.oext_type_name = oext_type_name; - Ast_410.Outcometree.oext_type_params = - (List.map (fun x -> x) oext_type_params); - Ast_410.Outcometree.oext_args = (List.map copy_out_type oext_args); - Ast_410.Outcometree.oext_ret_type = - (map_option copy_out_type oext_ret_type); - Ast_410.Outcometree.oext_private = (copy_private_flag oext_private) - } + { + Ast_410.Outcometree.oext_name = oext_name; + Ast_410.Outcometree.oext_type_name = oext_type_name; + Ast_410.Outcometree.oext_type_params = + (List.map (fun x -> x) oext_type_params); + Ast_410.Outcometree.oext_args = (List.map copy_out_type oext_args); + Ast_410.Outcometree.oext_ret_type = + (Option.map copy_out_type oext_ret_type); + Ast_410.Outcometree.oext_private = (copy_private_flag oext_private) + } +and copy_private_flag : + Ast_409.Asttypes.private_flag -> Ast_410.Asttypes.private_flag = + function + | Ast_409.Asttypes.Private -> Ast_410.Asttypes.Private + | Ast_409.Asttypes.Public -> Ast_410.Asttypes.Public and copy_out_rec_status : Ast_409.Outcometree.out_rec_status -> Ast_410.Outcometree.out_rec_status = function @@ -178,11 +180,11 @@ and copy_out_class_type : (x0, (copy_out_type x1), (copy_out_class_type x2)) | Ast_409.Outcometree.Octy_signature (x0, x1) -> Ast_410.Outcometree.Octy_signature - ((map_option copy_out_type x0), - (List.map copy_out_class_sig_item x1)) + ((Option.map copy_out_type x0), + (List.map copy_out_class_sig_item x1)) and copy_out_class_sig_item : Ast_409.Outcometree.out_class_sig_item -> - Ast_410.Outcometree.out_class_sig_item + Ast_410.Outcometree.out_class_sig_item = function | Ast_409.Outcometree.Ocsg_constraint (x0, x1) -> @@ -214,7 +216,7 @@ and copy_out_type : | Ast_409.Outcometree.Otyp_object (x0, x1) -> Ast_410.Outcometree.Otyp_object ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0), - (map_option (fun x -> x) x1)) + (Option.map (fun x -> x) x1)) | Ast_409.Outcometree.Otyp_record x0 -> Ast_410.Outcometree.Otyp_record (List.map @@ -226,7 +228,7 @@ and copy_out_type : (fun x -> let (x0, x1, x2) = x in (x0, (List.map copy_out_type x1), - (map_option copy_out_type x2))) x0) + (Option.map copy_out_type x2))) x0) | Ast_409.Outcometree.Otyp_tuple x0 -> Ast_410.Outcometree.Otyp_tuple (List.map copy_out_type x0) | Ast_409.Outcometree.Otyp_var (x0, x1) -> @@ -234,21 +236,21 @@ and copy_out_type : | Ast_409.Outcometree.Otyp_variant (x0, x1, x2, x3) -> Ast_410.Outcometree.Otyp_variant (x0, (copy_out_variant x1), x2, - (map_option (fun x -> List.map (fun x -> x) x) x3)) + (Option.map (fun x -> List.map (fun x -> x) x) x3)) | Ast_409.Outcometree.Otyp_poly (x0, x1) -> Ast_410.Outcometree.Otyp_poly ((List.map (fun x -> x) x0), (copy_out_type x1)) | Ast_409.Outcometree.Otyp_module (x0, x1, x2) -> Ast_410.Outcometree.Otyp_module ((copy_out_ident x0), (List.map (fun x -> x) x1), - (List.map copy_out_type x2)) + (List.map copy_out_type x2)) | Ast_409.Outcometree.Otyp_attribute (x0, x1) -> Ast_410.Outcometree.Otyp_attribute ((copy_out_type x0), (copy_out_attribute x1)) and copy_out_attribute : Ast_409.Outcometree.out_attribute -> Ast_410.Outcometree.out_attribute = fun { Ast_409.Outcometree.oattr_name = oattr_name } -> - { Ast_410.Outcometree.oattr_name = oattr_name } + { Ast_410.Outcometree.oattr_name = oattr_name } and copy_out_variant : Ast_409.Outcometree.out_variant -> Ast_410.Outcometree.out_variant = function @@ -292,7 +294,7 @@ and copy_out_value : | Ast_409.Outcometree.Oval_tuple x0 -> Ast_410.Outcometree.Oval_tuple (List.map copy_out_value x0) | Ast_409.Outcometree.Oval_variant (x0, x1) -> - Ast_410.Outcometree.Oval_variant (x0, (map_option copy_out_value x1)) + Ast_410.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1)) and copy_out_string : Ast_409.Outcometree.out_string -> Ast_410.Outcometree.out_string = function @@ -311,1204 +313,4 @@ and copy_out_ident : and copy_out_name : Ast_409.Outcometree.out_name -> Ast_410.Outcometree.out_name = fun { Ast_409.Outcometree.printed_name = printed_name } -> - { Ast_410.Outcometree.printed_name = printed_name } -and copy_toplevel_phrase : - Ast_409.Parsetree.toplevel_phrase -> Ast_410.Parsetree.toplevel_phrase = - function - | Ast_409.Parsetree.Ptop_def x0 -> - Ast_410.Parsetree.Ptop_def (copy_structure x0) - | Ast_409.Parsetree.Ptop_dir x0 -> - Ast_410.Parsetree.Ptop_dir (copy_toplevel_directive x0) -and copy_toplevel_directive : - Ast_409.Parsetree.toplevel_directive -> - Ast_410.Parsetree.toplevel_directive - = - fun - { Ast_409.Parsetree.pdir_name = pdir_name; - Ast_409.Parsetree.pdir_arg = pdir_arg; - Ast_409.Parsetree.pdir_loc = pdir_loc } - -> - { - Ast_410.Parsetree.pdir_name = (copy_loc (fun x -> x) pdir_name); - Ast_410.Parsetree.pdir_arg = - (map_option copy_directive_argument pdir_arg); - Ast_410.Parsetree.pdir_loc = (copy_location pdir_loc) - } -and copy_directive_argument : - Ast_409.Parsetree.directive_argument -> - Ast_410.Parsetree.directive_argument - = - fun - { Ast_409.Parsetree.pdira_desc = pdira_desc; - Ast_409.Parsetree.pdira_loc = pdira_loc } - -> - { - Ast_410.Parsetree.pdira_desc = - (copy_directive_argument_desc pdira_desc); - Ast_410.Parsetree.pdira_loc = (copy_location pdira_loc) - } -and copy_directive_argument_desc : - Ast_409.Parsetree.directive_argument_desc -> - Ast_410.Parsetree.directive_argument_desc - = - function - | Ast_409.Parsetree.Pdir_string x0 -> Ast_410.Parsetree.Pdir_string x0 - | Ast_409.Parsetree.Pdir_int (x0, x1) -> - Ast_410.Parsetree.Pdir_int (x0, (map_option (fun x -> x) x1)) - | Ast_409.Parsetree.Pdir_ident x0 -> - Ast_410.Parsetree.Pdir_ident (copy_Longident_t x0) - | Ast_409.Parsetree.Pdir_bool x0 -> Ast_410.Parsetree.Pdir_bool x0 -and copy_expression : - Ast_409.Parsetree.expression -> Ast_410.Parsetree.expression = - fun - { Ast_409.Parsetree.pexp_desc = pexp_desc; - Ast_409.Parsetree.pexp_loc = pexp_loc; - Ast_409.Parsetree.pexp_loc_stack = pexp_loc_stack; - Ast_409.Parsetree.pexp_attributes = pexp_attributes } - -> - { - Ast_410.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - Ast_410.Parsetree.pexp_loc = (copy_location pexp_loc); - Ast_410.Parsetree.pexp_loc_stack = - (List.map copy_location pexp_loc_stack); - Ast_410.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } -and copy_expression_desc : - Ast_409.Parsetree.expression_desc -> Ast_410.Parsetree.expression_desc = - function - | Ast_409.Parsetree.Pexp_ident x0 -> - Ast_410.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) - | Ast_409.Parsetree.Pexp_constant x0 -> - Ast_410.Parsetree.Pexp_constant (copy_constant x0) - | Ast_409.Parsetree.Pexp_let (x0, x1, x2) -> - Ast_410.Parsetree.Pexp_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_expression x2)) - | Ast_409.Parsetree.Pexp_function x0 -> - Ast_410.Parsetree.Pexp_function (copy_cases x0) - | Ast_409.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_410.Parsetree.Pexp_fun - ((copy_arg_label x0), (map_option copy_expression x1), - (copy_pattern x2), (copy_expression x3)) - | Ast_409.Parsetree.Pexp_apply (x0, x1) -> - Ast_410.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_409.Parsetree.Pexp_match (x0, x1) -> - Ast_410.Parsetree.Pexp_match ((copy_expression x0), (copy_cases x1)) - | Ast_409.Parsetree.Pexp_try (x0, x1) -> - Ast_410.Parsetree.Pexp_try ((copy_expression x0), (copy_cases x1)) - | Ast_409.Parsetree.Pexp_tuple x0 -> - Ast_410.Parsetree.Pexp_tuple (List.map copy_expression x0) - | Ast_409.Parsetree.Pexp_construct (x0, x1) -> - Ast_410.Parsetree.Pexp_construct - ((copy_loc copy_Longident_t x0), (map_option copy_expression x1)) - | Ast_409.Parsetree.Pexp_variant (x0, x1) -> - Ast_410.Parsetree.Pexp_variant - ((copy_label x0), (map_option copy_expression x1)) - | Ast_409.Parsetree.Pexp_record (x0, x1) -> - Ast_410.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_expression x1))) x0), - (map_option copy_expression x1)) - | Ast_409.Parsetree.Pexp_field (x0, x1) -> - Ast_410.Parsetree.Pexp_field - ((copy_expression x0), (copy_loc copy_Longident_t x1)) - | Ast_409.Parsetree.Pexp_setfield (x0, x1, x2) -> - Ast_410.Parsetree.Pexp_setfield - ((copy_expression x0), (copy_loc copy_Longident_t x1), - (copy_expression x2)) - | Ast_409.Parsetree.Pexp_array x0 -> - Ast_410.Parsetree.Pexp_array (List.map copy_expression x0) - | Ast_409.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> - Ast_410.Parsetree.Pexp_ifthenelse - ((copy_expression x0), (copy_expression x1), - (map_option copy_expression x2)) - | Ast_409.Parsetree.Pexp_sequence (x0, x1) -> - Ast_410.Parsetree.Pexp_sequence - ((copy_expression x0), (copy_expression x1)) - | Ast_409.Parsetree.Pexp_while (x0, x1) -> - Ast_410.Parsetree.Pexp_while - ((copy_expression x0), (copy_expression x1)) - | Ast_409.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> - Ast_410.Parsetree.Pexp_for - ((copy_pattern x0), (copy_expression x1), (copy_expression x2), - (copy_direction_flag x3), (copy_expression x4)) - | Ast_409.Parsetree.Pexp_constraint (x0, x1) -> - Ast_410.Parsetree.Pexp_constraint - ((copy_expression x0), (copy_core_type x1)) - | Ast_409.Parsetree.Pexp_coerce (x0, x1, x2) -> - Ast_410.Parsetree.Pexp_coerce - ((copy_expression x0), (map_option copy_core_type x1), - (copy_core_type x2)) - | Ast_409.Parsetree.Pexp_send (x0, x1) -> - Ast_410.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc copy_label x1)) - | Ast_409.Parsetree.Pexp_new x0 -> - Ast_410.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) - | Ast_409.Parsetree.Pexp_setinstvar (x0, x1) -> - Ast_410.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), (copy_expression x1)) - | Ast_409.Parsetree.Pexp_override x0 -> - Ast_410.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_label x0), (copy_expression x1))) x0) - | Ast_409.Parsetree.Pexp_letmodule (x0, x1, x2) -> - Ast_410.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> Some x) x0), (copy_module_expr x1), - (copy_expression x2)) - | Ast_409.Parsetree.Pexp_letexception (x0, x1) -> - Ast_410.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), (copy_expression x1)) - | Ast_409.Parsetree.Pexp_assert x0 -> - Ast_410.Parsetree.Pexp_assert (copy_expression x0) - | Ast_409.Parsetree.Pexp_lazy x0 -> - Ast_410.Parsetree.Pexp_lazy (copy_expression x0) - | Ast_409.Parsetree.Pexp_poly (x0, x1) -> - Ast_410.Parsetree.Pexp_poly - ((copy_expression x0), (map_option copy_core_type x1)) - | Ast_409.Parsetree.Pexp_object x0 -> - Ast_410.Parsetree.Pexp_object (copy_class_structure x0) - | Ast_409.Parsetree.Pexp_newtype (x0, x1) -> - Ast_410.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | Ast_409.Parsetree.Pexp_pack x0 -> - Ast_410.Parsetree.Pexp_pack (copy_module_expr x0) - | Ast_409.Parsetree.Pexp_open (x0, x1) -> - Ast_410.Parsetree.Pexp_open - ((copy_open_declaration x0), (copy_expression x1)) - | Ast_409.Parsetree.Pexp_letop x0 -> - Ast_410.Parsetree.Pexp_letop (copy_letop x0) - | Ast_409.Parsetree.Pexp_extension x0 -> - Ast_410.Parsetree.Pexp_extension (copy_extension x0) - | Ast_409.Parsetree.Pexp_unreachable -> Ast_410.Parsetree.Pexp_unreachable -and copy_letop : Ast_409.Parsetree.letop -> Ast_410.Parsetree.letop = - fun - { Ast_409.Parsetree.let_ = let_; Ast_409.Parsetree.ands = ands; - Ast_409.Parsetree.body = body } - -> - { - Ast_410.Parsetree.let_ = (copy_binding_op let_); - Ast_410.Parsetree.ands = (List.map copy_binding_op ands); - Ast_410.Parsetree.body = (copy_expression body) - } -and copy_binding_op : - Ast_409.Parsetree.binding_op -> Ast_410.Parsetree.binding_op = - fun - { Ast_409.Parsetree.pbop_op = pbop_op; - Ast_409.Parsetree.pbop_pat = pbop_pat; - Ast_409.Parsetree.pbop_exp = pbop_exp; - Ast_409.Parsetree.pbop_loc = pbop_loc } - -> - { - Ast_410.Parsetree.pbop_op = (copy_loc (fun x -> x) pbop_op); - Ast_410.Parsetree.pbop_pat = (copy_pattern pbop_pat); - Ast_410.Parsetree.pbop_exp = (copy_expression pbop_exp); - Ast_410.Parsetree.pbop_loc = (copy_location pbop_loc) - } -and copy_direction_flag : - Ast_409.Asttypes.direction_flag -> Ast_410.Asttypes.direction_flag = - function - | Ast_409.Asttypes.Upto -> Ast_410.Asttypes.Upto - | Ast_409.Asttypes.Downto -> Ast_410.Asttypes.Downto -and copy_cases : Ast_409.Parsetree.cases -> Ast_410.Parsetree.case list = - fun x -> List.map copy_case x -and copy_case : Ast_409.Parsetree.case -> Ast_410.Parsetree.case = - fun - { Ast_409.Parsetree.pc_lhs = pc_lhs; - Ast_409.Parsetree.pc_guard = pc_guard; - Ast_409.Parsetree.pc_rhs = pc_rhs } - -> - { - Ast_410.Parsetree.pc_lhs = (copy_pattern pc_lhs); - Ast_410.Parsetree.pc_guard = (map_option copy_expression pc_guard); - Ast_410.Parsetree.pc_rhs = (copy_expression pc_rhs) - } -and copy_value_binding : - Ast_409.Parsetree.value_binding -> Ast_410.Parsetree.value_binding = - fun - { Ast_409.Parsetree.pvb_pat = pvb_pat; - Ast_409.Parsetree.pvb_expr = pvb_expr; - Ast_409.Parsetree.pvb_attributes = pvb_attributes; - Ast_409.Parsetree.pvb_loc = pvb_loc } - -> - { - Ast_410.Parsetree.pvb_pat = (copy_pattern pvb_pat); - Ast_410.Parsetree.pvb_expr = (copy_expression pvb_expr); - Ast_410.Parsetree.pvb_attributes = (copy_attributes pvb_attributes); - Ast_410.Parsetree.pvb_loc = (copy_location pvb_loc) - } -and copy_pattern : Ast_409.Parsetree.pattern -> Ast_410.Parsetree.pattern = - fun - { Ast_409.Parsetree.ppat_desc = ppat_desc; - Ast_409.Parsetree.ppat_loc = ppat_loc; - Ast_409.Parsetree.ppat_loc_stack = ppat_loc_stack; - Ast_409.Parsetree.ppat_attributes = ppat_attributes } - -> - { - Ast_410.Parsetree.ppat_desc = (copy_pattern_desc ppat_desc); - Ast_410.Parsetree.ppat_loc = (copy_location ppat_loc); - Ast_410.Parsetree.ppat_loc_stack = - (List.map copy_location ppat_loc_stack); - Ast_410.Parsetree.ppat_attributes = (copy_attributes ppat_attributes) - } -and copy_pattern_desc : - Ast_409.Parsetree.pattern_desc -> Ast_410.Parsetree.pattern_desc = - function - | Ast_409.Parsetree.Ppat_any -> Ast_410.Parsetree.Ppat_any - | Ast_409.Parsetree.Ppat_var x0 -> - Ast_410.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | Ast_409.Parsetree.Ppat_alias (x0, x1) -> - Ast_410.Parsetree.Ppat_alias - ((copy_pattern x0), (copy_loc (fun x -> x) x1)) - | Ast_409.Parsetree.Ppat_constant x0 -> - Ast_410.Parsetree.Ppat_constant (copy_constant x0) - | Ast_409.Parsetree.Ppat_interval (x0, x1) -> - Ast_410.Parsetree.Ppat_interval - ((copy_constant x0), (copy_constant x1)) - | Ast_409.Parsetree.Ppat_tuple x0 -> - Ast_410.Parsetree.Ppat_tuple (List.map copy_pattern x0) - | Ast_409.Parsetree.Ppat_construct (x0, x1) -> - Ast_410.Parsetree.Ppat_construct - ((copy_loc copy_Longident_t x0), (map_option copy_pattern x1)) - | Ast_409.Parsetree.Ppat_variant (x0, x1) -> - Ast_410.Parsetree.Ppat_variant - ((copy_label x0), (map_option copy_pattern x1)) - | Ast_409.Parsetree.Ppat_record (x0, x1) -> - Ast_410.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | Ast_409.Parsetree.Ppat_array x0 -> - Ast_410.Parsetree.Ppat_array (List.map copy_pattern x0) - | Ast_409.Parsetree.Ppat_or (x0, x1) -> - Ast_410.Parsetree.Ppat_or ((copy_pattern x0), (copy_pattern x1)) - | Ast_409.Parsetree.Ppat_constraint (x0, x1) -> - Ast_410.Parsetree.Ppat_constraint - ((copy_pattern x0), (copy_core_type x1)) - | Ast_409.Parsetree.Ppat_type x0 -> - Ast_410.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) - | Ast_409.Parsetree.Ppat_lazy x0 -> - Ast_410.Parsetree.Ppat_lazy (copy_pattern x0) - | Ast_409.Parsetree.Ppat_unpack x0 -> - Ast_410.Parsetree.Ppat_unpack (copy_loc (fun x -> Some x) x0) - | Ast_409.Parsetree.Ppat_exception x0 -> - Ast_410.Parsetree.Ppat_exception (copy_pattern x0) - | Ast_409.Parsetree.Ppat_extension x0 -> - Ast_410.Parsetree.Ppat_extension (copy_extension x0) - | Ast_409.Parsetree.Ppat_open (x0, x1) -> - Ast_410.Parsetree.Ppat_open - ((copy_loc copy_Longident_t x0), (copy_pattern x1)) -and copy_core_type : - Ast_409.Parsetree.core_type -> Ast_410.Parsetree.core_type = - fun - { Ast_409.Parsetree.ptyp_desc = ptyp_desc; - Ast_409.Parsetree.ptyp_loc = ptyp_loc; - Ast_409.Parsetree.ptyp_loc_stack = ptyp_loc_stack; - Ast_409.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - Ast_410.Parsetree.ptyp_desc = (copy_core_type_desc ptyp_desc); - Ast_410.Parsetree.ptyp_loc = (copy_location ptyp_loc); - Ast_410.Parsetree.ptyp_loc_stack = - (List.map copy_location ptyp_loc_stack); - Ast_410.Parsetree.ptyp_attributes = (copy_attributes ptyp_attributes) - } -and copy_core_type_desc : - Ast_409.Parsetree.core_type_desc -> Ast_410.Parsetree.core_type_desc = - function - | Ast_409.Parsetree.Ptyp_any -> Ast_410.Parsetree.Ptyp_any - | Ast_409.Parsetree.Ptyp_var x0 -> Ast_410.Parsetree.Ptyp_var x0 - | Ast_409.Parsetree.Ptyp_arrow (x0, x1, x2) -> - Ast_410.Parsetree.Ptyp_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_core_type x2)) - | Ast_409.Parsetree.Ptyp_tuple x0 -> - Ast_410.Parsetree.Ptyp_tuple (List.map copy_core_type x0) - | Ast_409.Parsetree.Ptyp_constr (x0, x1) -> - Ast_410.Parsetree.Ptyp_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_409.Parsetree.Ptyp_object (x0, x1) -> - Ast_410.Parsetree.Ptyp_object - ((List.map copy_object_field x0), (copy_closed_flag x1)) - | Ast_409.Parsetree.Ptyp_class (x0, x1) -> - Ast_410.Parsetree.Ptyp_class - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_409.Parsetree.Ptyp_alias (x0, x1) -> - Ast_410.Parsetree.Ptyp_alias ((copy_core_type x0), x1) - | Ast_409.Parsetree.Ptyp_variant (x0, x1, x2) -> - Ast_410.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), (copy_closed_flag x1), - (map_option (fun x -> List.map copy_label x) x2)) - | Ast_409.Parsetree.Ptyp_poly (x0, x1) -> - Ast_410.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | Ast_409.Parsetree.Ptyp_package x0 -> - Ast_410.Parsetree.Ptyp_package (copy_package_type x0) - | Ast_409.Parsetree.Ptyp_extension x0 -> - Ast_410.Parsetree.Ptyp_extension (copy_extension x0) -and copy_package_type : - Ast_409.Parsetree.package_type -> Ast_410.Parsetree.package_type = - fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_core_type x1))) x1)) -and copy_row_field : - Ast_409.Parsetree.row_field -> Ast_410.Parsetree.row_field = - fun - { Ast_409.Parsetree.prf_desc = prf_desc; - Ast_409.Parsetree.prf_loc = prf_loc; - Ast_409.Parsetree.prf_attributes = prf_attributes } - -> - { - Ast_410.Parsetree.prf_desc = (copy_row_field_desc prf_desc); - Ast_410.Parsetree.prf_loc = (copy_location prf_loc); - Ast_410.Parsetree.prf_attributes = (copy_attributes prf_attributes) - } -and copy_row_field_desc : - Ast_409.Parsetree.row_field_desc -> Ast_410.Parsetree.row_field_desc = - function - | Ast_409.Parsetree.Rtag (x0, x1, x2) -> - Ast_410.Parsetree.Rtag - ((copy_loc copy_label x0), x1, (List.map copy_core_type x2)) - | Ast_409.Parsetree.Rinherit x0 -> - Ast_410.Parsetree.Rinherit (copy_core_type x0) -and copy_object_field : - Ast_409.Parsetree.object_field -> Ast_410.Parsetree.object_field = - fun - { Ast_409.Parsetree.pof_desc = pof_desc; - Ast_409.Parsetree.pof_loc = pof_loc; - Ast_409.Parsetree.pof_attributes = pof_attributes } - -> - { - Ast_410.Parsetree.pof_desc = (copy_object_field_desc pof_desc); - Ast_410.Parsetree.pof_loc = (copy_location pof_loc); - Ast_410.Parsetree.pof_attributes = (copy_attributes pof_attributes) - } -and copy_attributes : - Ast_409.Parsetree.attributes -> Ast_410.Parsetree.attributes = - fun x -> List.map copy_attribute x -and copy_attribute : - Ast_409.Parsetree.attribute -> Ast_410.Parsetree.attribute = - fun - { Ast_409.Parsetree.attr_name = attr_name; - Ast_409.Parsetree.attr_payload = attr_payload; - Ast_409.Parsetree.attr_loc = attr_loc } - -> - { - Ast_410.Parsetree.attr_name = (copy_loc (fun x -> x) attr_name); - Ast_410.Parsetree.attr_payload = (copy_payload attr_payload); - Ast_410.Parsetree.attr_loc = (copy_location attr_loc) - } -and copy_payload : Ast_409.Parsetree.payload -> Ast_410.Parsetree.payload = - function - | Ast_409.Parsetree.PStr x0 -> Ast_410.Parsetree.PStr (copy_structure x0) - | Ast_409.Parsetree.PSig x0 -> Ast_410.Parsetree.PSig (copy_signature x0) - | Ast_409.Parsetree.PTyp x0 -> Ast_410.Parsetree.PTyp (copy_core_type x0) - | Ast_409.Parsetree.PPat (x0, x1) -> - Ast_410.Parsetree.PPat - ((copy_pattern x0), (map_option copy_expression x1)) -and copy_structure : - Ast_409.Parsetree.structure -> Ast_410.Parsetree.structure = - fun x -> List.map copy_structure_item x -and copy_structure_item : - Ast_409.Parsetree.structure_item -> Ast_410.Parsetree.structure_item = - fun - { Ast_409.Parsetree.pstr_desc = pstr_desc; - Ast_409.Parsetree.pstr_loc = pstr_loc } - -> - { - Ast_410.Parsetree.pstr_desc = (copy_structure_item_desc pstr_desc); - Ast_410.Parsetree.pstr_loc = (copy_location pstr_loc) - } -and copy_structure_item_desc : - Ast_409.Parsetree.structure_item_desc -> - Ast_410.Parsetree.structure_item_desc - = - function - | Ast_409.Parsetree.Pstr_eval (x0, x1) -> - Ast_410.Parsetree.Pstr_eval - ((copy_expression x0), (copy_attributes x1)) - | Ast_409.Parsetree.Pstr_value (x0, x1) -> - Ast_410.Parsetree.Pstr_value - ((copy_rec_flag x0), (List.map copy_value_binding x1)) - | Ast_409.Parsetree.Pstr_primitive x0 -> - Ast_410.Parsetree.Pstr_primitive (copy_value_description x0) - | Ast_409.Parsetree.Pstr_type (x0, x1) -> - Ast_410.Parsetree.Pstr_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_409.Parsetree.Pstr_typext x0 -> - Ast_410.Parsetree.Pstr_typext (copy_type_extension x0) - | Ast_409.Parsetree.Pstr_exception x0 -> - Ast_410.Parsetree.Pstr_exception (copy_type_exception x0) - | Ast_409.Parsetree.Pstr_module x0 -> - Ast_410.Parsetree.Pstr_module (copy_module_binding x0) - | Ast_409.Parsetree.Pstr_recmodule x0 -> - Ast_410.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) - | Ast_409.Parsetree.Pstr_modtype x0 -> - Ast_410.Parsetree.Pstr_modtype (copy_module_type_declaration x0) - | Ast_409.Parsetree.Pstr_open x0 -> - Ast_410.Parsetree.Pstr_open (copy_open_declaration x0) - | Ast_409.Parsetree.Pstr_class x0 -> - Ast_410.Parsetree.Pstr_class (List.map copy_class_declaration x0) - | Ast_409.Parsetree.Pstr_class_type x0 -> - Ast_410.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | Ast_409.Parsetree.Pstr_include x0 -> - Ast_410.Parsetree.Pstr_include (copy_include_declaration x0) - | Ast_409.Parsetree.Pstr_attribute x0 -> - Ast_410.Parsetree.Pstr_attribute (copy_attribute x0) - | Ast_409.Parsetree.Pstr_extension (x0, x1) -> - Ast_410.Parsetree.Pstr_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_include_declaration : - Ast_409.Parsetree.include_declaration -> - Ast_410.Parsetree.include_declaration - = fun x -> copy_include_infos copy_module_expr x -and copy_class_declaration : - Ast_409.Parsetree.class_declaration -> Ast_410.Parsetree.class_declaration - = fun x -> copy_class_infos copy_class_expr x -and copy_class_expr : - Ast_409.Parsetree.class_expr -> Ast_410.Parsetree.class_expr = - fun - { Ast_409.Parsetree.pcl_desc = pcl_desc; - Ast_409.Parsetree.pcl_loc = pcl_loc; - Ast_409.Parsetree.pcl_attributes = pcl_attributes } - -> - { - Ast_410.Parsetree.pcl_desc = (copy_class_expr_desc pcl_desc); - Ast_410.Parsetree.pcl_loc = (copy_location pcl_loc); - Ast_410.Parsetree.pcl_attributes = (copy_attributes pcl_attributes) - } -and copy_class_expr_desc : - Ast_409.Parsetree.class_expr_desc -> Ast_410.Parsetree.class_expr_desc = - function - | Ast_409.Parsetree.Pcl_constr (x0, x1) -> - Ast_410.Parsetree.Pcl_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_409.Parsetree.Pcl_structure x0 -> - Ast_410.Parsetree.Pcl_structure (copy_class_structure x0) - | Ast_409.Parsetree.Pcl_fun (x0, x1, x2, x3) -> - Ast_410.Parsetree.Pcl_fun - ((copy_arg_label x0), (map_option copy_expression x1), - (copy_pattern x2), (copy_class_expr x3)) - | Ast_409.Parsetree.Pcl_apply (x0, x1) -> - Ast_410.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_409.Parsetree.Pcl_let (x0, x1, x2) -> - Ast_410.Parsetree.Pcl_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_class_expr x2)) - | Ast_409.Parsetree.Pcl_constraint (x0, x1) -> - Ast_410.Parsetree.Pcl_constraint - ((copy_class_expr x0), (copy_class_type x1)) - | Ast_409.Parsetree.Pcl_extension x0 -> - Ast_410.Parsetree.Pcl_extension (copy_extension x0) - | Ast_409.Parsetree.Pcl_open (x0, x1) -> - Ast_410.Parsetree.Pcl_open - ((copy_open_description x0), (copy_class_expr x1)) -and copy_class_structure : - Ast_409.Parsetree.class_structure -> Ast_410.Parsetree.class_structure = - fun - { Ast_409.Parsetree.pcstr_self = pcstr_self; - Ast_409.Parsetree.pcstr_fields = pcstr_fields } - -> - { - Ast_410.Parsetree.pcstr_self = (copy_pattern pcstr_self); - Ast_410.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } -and copy_class_field : - Ast_409.Parsetree.class_field -> Ast_410.Parsetree.class_field = - fun - { Ast_409.Parsetree.pcf_desc = pcf_desc; - Ast_409.Parsetree.pcf_loc = pcf_loc; - Ast_409.Parsetree.pcf_attributes = pcf_attributes } - -> - { - Ast_410.Parsetree.pcf_desc = (copy_class_field_desc pcf_desc); - Ast_410.Parsetree.pcf_loc = (copy_location pcf_loc); - Ast_410.Parsetree.pcf_attributes = (copy_attributes pcf_attributes) - } -and copy_class_field_desc : - Ast_409.Parsetree.class_field_desc -> Ast_410.Parsetree.class_field_desc = - function - | Ast_409.Parsetree.Pcf_inherit (x0, x1, x2) -> - Ast_410.Parsetree.Pcf_inherit - ((copy_override_flag x0), (copy_class_expr x1), - (map_option (fun x -> copy_loc (fun x -> x) x) x2)) - | Ast_409.Parsetree.Pcf_val x0 -> - Ast_410.Parsetree.Pcf_val - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | Ast_409.Parsetree.Pcf_method x0 -> - Ast_410.Parsetree.Pcf_method - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_class_field_kind x2))) - | Ast_409.Parsetree.Pcf_constraint x0 -> - Ast_410.Parsetree.Pcf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_409.Parsetree.Pcf_initializer x0 -> - Ast_410.Parsetree.Pcf_initializer (copy_expression x0) - | Ast_409.Parsetree.Pcf_attribute x0 -> - Ast_410.Parsetree.Pcf_attribute (copy_attribute x0) - | Ast_409.Parsetree.Pcf_extension x0 -> - Ast_410.Parsetree.Pcf_extension (copy_extension x0) -and copy_class_field_kind : - Ast_409.Parsetree.class_field_kind -> Ast_410.Parsetree.class_field_kind = - function - | Ast_409.Parsetree.Cfk_virtual x0 -> - Ast_410.Parsetree.Cfk_virtual (copy_core_type x0) - | Ast_409.Parsetree.Cfk_concrete (x0, x1) -> - Ast_410.Parsetree.Cfk_concrete - ((copy_override_flag x0), (copy_expression x1)) -and copy_open_declaration : - Ast_409.Parsetree.open_declaration -> Ast_410.Parsetree.open_declaration = - fun x -> copy_open_infos copy_module_expr x -and copy_module_binding : - Ast_409.Parsetree.module_binding -> Ast_410.Parsetree.module_binding = - fun - { Ast_409.Parsetree.pmb_name = pmb_name; - Ast_409.Parsetree.pmb_expr = pmb_expr; - Ast_409.Parsetree.pmb_attributes = pmb_attributes; - Ast_409.Parsetree.pmb_loc = pmb_loc } - -> - { - Ast_410.Parsetree.pmb_name = (copy_loc (fun x -> Some x) pmb_name); - Ast_410.Parsetree.pmb_expr = (copy_module_expr pmb_expr); - Ast_410.Parsetree.pmb_attributes = (copy_attributes pmb_attributes); - Ast_410.Parsetree.pmb_loc = (copy_location pmb_loc) - } -and copy_module_expr : - Ast_409.Parsetree.module_expr -> Ast_410.Parsetree.module_expr = - fun - { Ast_409.Parsetree.pmod_desc = pmod_desc; - Ast_409.Parsetree.pmod_loc = pmod_loc; - Ast_409.Parsetree.pmod_attributes = pmod_attributes } - -> - { - Ast_410.Parsetree.pmod_desc = (copy_module_expr_desc pmod_desc); - Ast_410.Parsetree.pmod_loc = (copy_location pmod_loc); - Ast_410.Parsetree.pmod_attributes = (copy_attributes pmod_attributes) - } -and copy_module_expr_desc : - Ast_409.Parsetree.module_expr_desc -> Ast_410.Parsetree.module_expr_desc = - function - | Ast_409.Parsetree.Pmod_ident x0 -> - Ast_410.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) - | Ast_409.Parsetree.Pmod_structure x0 -> - Ast_410.Parsetree.Pmod_structure (copy_structure x0) - | Ast_409.Parsetree.Pmod_functor (x0, x1, x2) -> - Ast_410.Parsetree.Pmod_functor - ((match x0.txt, x1 with - | "*", None -> Unit - | "_", Some mt -> Named (copy_loc (fun _ -> None) x0, copy_module_type mt) - | _, Some mt -> Named (copy_loc (fun x -> Some x) x0, copy_module_type mt) - |_ -> assert false), - (copy_module_expr x2)) - | Ast_409.Parsetree.Pmod_apply (x0, x1) -> - Ast_410.Parsetree.Pmod_apply - ((copy_module_expr x0), (copy_module_expr x1)) - | Ast_409.Parsetree.Pmod_constraint (x0, x1) -> - Ast_410.Parsetree.Pmod_constraint - ((copy_module_expr x0), (copy_module_type x1)) - | Ast_409.Parsetree.Pmod_unpack x0 -> - Ast_410.Parsetree.Pmod_unpack (copy_expression x0) - | Ast_409.Parsetree.Pmod_extension x0 -> - Ast_410.Parsetree.Pmod_extension (copy_extension x0) -and copy_module_type : - Ast_409.Parsetree.module_type -> Ast_410.Parsetree.module_type = - fun - { Ast_409.Parsetree.pmty_desc = pmty_desc; - Ast_409.Parsetree.pmty_loc = pmty_loc; - Ast_409.Parsetree.pmty_attributes = pmty_attributes } - -> - { - Ast_410.Parsetree.pmty_desc = (copy_module_type_desc pmty_desc); - Ast_410.Parsetree.pmty_loc = (copy_location pmty_loc); - Ast_410.Parsetree.pmty_attributes = (copy_attributes pmty_attributes) - } -and copy_module_type_desc : - Ast_409.Parsetree.module_type_desc -> Ast_410.Parsetree.module_type_desc = - function - | Ast_409.Parsetree.Pmty_ident x0 -> - Ast_410.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) - | Ast_409.Parsetree.Pmty_signature x0 -> - Ast_410.Parsetree.Pmty_signature (copy_signature x0) - | Ast_409.Parsetree.Pmty_functor (x0, x1, x2) -> - Ast_410.Parsetree.Pmty_functor - ((match x0.txt, x1 with - | "*", None -> Unit - | "_", Some mt -> Named (copy_loc (fun _ -> None) x0, copy_module_type mt) - | _, Some mt -> Named (copy_loc (fun x -> Some x) x0, copy_module_type mt) - |_ -> assert false), - (copy_module_type x2)) - | Ast_409.Parsetree.Pmty_with (x0, x1) -> - Ast_410.Parsetree.Pmty_with - ((copy_module_type x0), (List.map copy_with_constraint x1)) - | Ast_409.Parsetree.Pmty_typeof x0 -> - Ast_410.Parsetree.Pmty_typeof (copy_module_expr x0) - | Ast_409.Parsetree.Pmty_extension x0 -> - Ast_410.Parsetree.Pmty_extension (copy_extension x0) - | Ast_409.Parsetree.Pmty_alias x0 -> - Ast_410.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) -and copy_with_constraint : - Ast_409.Parsetree.with_constraint -> Ast_410.Parsetree.with_constraint = - function - | Ast_409.Parsetree.Pwith_type (x0, x1) -> - Ast_410.Parsetree.Pwith_type - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_409.Parsetree.Pwith_module (x0, x1) -> - Ast_410.Parsetree.Pwith_module - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) - | Ast_409.Parsetree.Pwith_typesubst (x0, x1) -> - Ast_410.Parsetree.Pwith_typesubst - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_409.Parsetree.Pwith_modsubst (x0, x1) -> - Ast_410.Parsetree.Pwith_modsubst - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) -and copy_signature : - Ast_409.Parsetree.signature -> Ast_410.Parsetree.signature = - fun x -> List.map copy_signature_item x -and copy_signature_item : - Ast_409.Parsetree.signature_item -> Ast_410.Parsetree.signature_item = - fun - { Ast_409.Parsetree.psig_desc = psig_desc; - Ast_409.Parsetree.psig_loc = psig_loc } - -> - { - Ast_410.Parsetree.psig_desc = (copy_signature_item_desc psig_desc); - Ast_410.Parsetree.psig_loc = (copy_location psig_loc) - } -and copy_signature_item_desc : - Ast_409.Parsetree.signature_item_desc -> - Ast_410.Parsetree.signature_item_desc - = - function - | Ast_409.Parsetree.Psig_value x0 -> - Ast_410.Parsetree.Psig_value (copy_value_description x0) - | Ast_409.Parsetree.Psig_type (x0, x1) -> - Ast_410.Parsetree.Psig_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_409.Parsetree.Psig_typesubst x0 -> - Ast_410.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) - | Ast_409.Parsetree.Psig_typext x0 -> - Ast_410.Parsetree.Psig_typext (copy_type_extension x0) - | Ast_409.Parsetree.Psig_exception x0 -> - Ast_410.Parsetree.Psig_exception (copy_type_exception x0) - | Ast_409.Parsetree.Psig_module x0 -> - Ast_410.Parsetree.Psig_module (copy_module_declaration x0) - | Ast_409.Parsetree.Psig_modsubst x0 -> - Ast_410.Parsetree.Psig_modsubst (copy_module_substitution x0) - | Ast_409.Parsetree.Psig_recmodule x0 -> - Ast_410.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) - | Ast_409.Parsetree.Psig_modtype x0 -> - Ast_410.Parsetree.Psig_modtype (copy_module_type_declaration x0) - | Ast_409.Parsetree.Psig_open x0 -> - Ast_410.Parsetree.Psig_open (copy_open_description x0) - | Ast_409.Parsetree.Psig_include x0 -> - Ast_410.Parsetree.Psig_include (copy_include_description x0) - | Ast_409.Parsetree.Psig_class x0 -> - Ast_410.Parsetree.Psig_class (List.map copy_class_description x0) - | Ast_409.Parsetree.Psig_class_type x0 -> - Ast_410.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | Ast_409.Parsetree.Psig_attribute x0 -> - Ast_410.Parsetree.Psig_attribute (copy_attribute x0) - | Ast_409.Parsetree.Psig_extension (x0, x1) -> - Ast_410.Parsetree.Psig_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_class_type_declaration : - Ast_409.Parsetree.class_type_declaration -> - Ast_410.Parsetree.class_type_declaration - = fun x -> copy_class_infos copy_class_type x -and copy_class_description : - Ast_409.Parsetree.class_description -> Ast_410.Parsetree.class_description - = fun x -> copy_class_infos copy_class_type x -and copy_class_type : - Ast_409.Parsetree.class_type -> Ast_410.Parsetree.class_type = - fun - { Ast_409.Parsetree.pcty_desc = pcty_desc; - Ast_409.Parsetree.pcty_loc = pcty_loc; - Ast_409.Parsetree.pcty_attributes = pcty_attributes } - -> - { - Ast_410.Parsetree.pcty_desc = (copy_class_type_desc pcty_desc); - Ast_410.Parsetree.pcty_loc = (copy_location pcty_loc); - Ast_410.Parsetree.pcty_attributes = (copy_attributes pcty_attributes) - } -and copy_class_type_desc : - Ast_409.Parsetree.class_type_desc -> Ast_410.Parsetree.class_type_desc = - function - | Ast_409.Parsetree.Pcty_constr (x0, x1) -> - Ast_410.Parsetree.Pcty_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_409.Parsetree.Pcty_signature x0 -> - Ast_410.Parsetree.Pcty_signature (copy_class_signature x0) - | Ast_409.Parsetree.Pcty_arrow (x0, x1, x2) -> - Ast_410.Parsetree.Pcty_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_class_type x2)) - | Ast_409.Parsetree.Pcty_extension x0 -> - Ast_410.Parsetree.Pcty_extension (copy_extension x0) - | Ast_409.Parsetree.Pcty_open (x0, x1) -> - Ast_410.Parsetree.Pcty_open - ((copy_open_description x0), (copy_class_type x1)) -and copy_class_signature : - Ast_409.Parsetree.class_signature -> Ast_410.Parsetree.class_signature = - fun - { Ast_409.Parsetree.pcsig_self = pcsig_self; - Ast_409.Parsetree.pcsig_fields = pcsig_fields } - -> - { - Ast_410.Parsetree.pcsig_self = (copy_core_type pcsig_self); - Ast_410.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } -and copy_class_type_field : - Ast_409.Parsetree.class_type_field -> Ast_410.Parsetree.class_type_field = - fun - { Ast_409.Parsetree.pctf_desc = pctf_desc; - Ast_409.Parsetree.pctf_loc = pctf_loc; - Ast_409.Parsetree.pctf_attributes = pctf_attributes } - -> - { - Ast_410.Parsetree.pctf_desc = (copy_class_type_field_desc pctf_desc); - Ast_410.Parsetree.pctf_loc = (copy_location pctf_loc); - Ast_410.Parsetree.pctf_attributes = (copy_attributes pctf_attributes) - } -and copy_class_type_field_desc : - Ast_409.Parsetree.class_type_field_desc -> - Ast_410.Parsetree.class_type_field_desc - = - function - | Ast_409.Parsetree.Pctf_inherit x0 -> - Ast_410.Parsetree.Pctf_inherit (copy_class_type x0) - | Ast_409.Parsetree.Pctf_val x0 -> - Ast_410.Parsetree.Pctf_val - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_409.Parsetree.Pctf_method x0 -> - Ast_410.Parsetree.Pctf_method - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_409.Parsetree.Pctf_constraint x0 -> - Ast_410.Parsetree.Pctf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_409.Parsetree.Pctf_attribute x0 -> - Ast_410.Parsetree.Pctf_attribute (copy_attribute x0) - | Ast_409.Parsetree.Pctf_extension x0 -> - Ast_410.Parsetree.Pctf_extension (copy_extension x0) -and copy_extension : - Ast_409.Parsetree.extension -> Ast_410.Parsetree.extension = - fun x -> - let (x0, x1) = x in ((copy_loc (fun x -> x) x0), (copy_payload x1)) -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_409.Parsetree.class_infos -> 'g0 Ast_410.Parsetree.class_infos - = - fun f0 -> - fun - { Ast_409.Parsetree.pci_virt = pci_virt; - Ast_409.Parsetree.pci_params = pci_params; - Ast_409.Parsetree.pci_name = pci_name; - Ast_409.Parsetree.pci_expr = pci_expr; - Ast_409.Parsetree.pci_loc = pci_loc; - Ast_409.Parsetree.pci_attributes = pci_attributes } - -> - { - Ast_410.Parsetree.pci_virt = (copy_virtual_flag pci_virt); - Ast_410.Parsetree.pci_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - pci_params); - Ast_410.Parsetree.pci_name = (copy_loc (fun x -> x) pci_name); - Ast_410.Parsetree.pci_expr = (f0 pci_expr); - Ast_410.Parsetree.pci_loc = (copy_location pci_loc); - Ast_410.Parsetree.pci_attributes = (copy_attributes pci_attributes) - } -and copy_virtual_flag : - Ast_409.Asttypes.virtual_flag -> Ast_410.Asttypes.virtual_flag = - function - | Ast_409.Asttypes.Virtual -> Ast_410.Asttypes.Virtual - | Ast_409.Asttypes.Concrete -> Ast_410.Asttypes.Concrete -and copy_include_description : - Ast_409.Parsetree.include_description -> - Ast_410.Parsetree.include_description - = fun x -> copy_include_infos copy_module_type x -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_409.Parsetree.include_infos -> - 'g0 Ast_410.Parsetree.include_infos - = - fun f0 -> - fun - { Ast_409.Parsetree.pincl_mod = pincl_mod; - Ast_409.Parsetree.pincl_loc = pincl_loc; - Ast_409.Parsetree.pincl_attributes = pincl_attributes } - -> - { - Ast_410.Parsetree.pincl_mod = (f0 pincl_mod); - Ast_410.Parsetree.pincl_loc = (copy_location pincl_loc); - Ast_410.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } -and copy_open_description : - Ast_409.Parsetree.open_description -> Ast_410.Parsetree.open_description = - fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x -and copy_open_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_409.Parsetree.open_infos -> 'g0 Ast_410.Parsetree.open_infos - = - fun f0 -> - fun - { Ast_409.Parsetree.popen_expr = popen_expr; - Ast_409.Parsetree.popen_override = popen_override; - Ast_409.Parsetree.popen_loc = popen_loc; - Ast_409.Parsetree.popen_attributes = popen_attributes } - -> - { - Ast_410.Parsetree.popen_expr = (f0 popen_expr); - Ast_410.Parsetree.popen_override = - (copy_override_flag popen_override); - Ast_410.Parsetree.popen_loc = (copy_location popen_loc); - Ast_410.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } -and copy_override_flag : - Ast_409.Asttypes.override_flag -> Ast_410.Asttypes.override_flag = - function - | Ast_409.Asttypes.Override -> Ast_410.Asttypes.Override - | Ast_409.Asttypes.Fresh -> Ast_410.Asttypes.Fresh -and copy_module_type_declaration : - Ast_409.Parsetree.module_type_declaration -> - Ast_410.Parsetree.module_type_declaration - = - fun - { Ast_409.Parsetree.pmtd_name = pmtd_name; - Ast_409.Parsetree.pmtd_type = pmtd_type; - Ast_409.Parsetree.pmtd_attributes = pmtd_attributes; - Ast_409.Parsetree.pmtd_loc = pmtd_loc } - -> - { - Ast_410.Parsetree.pmtd_name = (copy_loc (fun x -> x) pmtd_name); - Ast_410.Parsetree.pmtd_type = (map_option copy_module_type pmtd_type); - Ast_410.Parsetree.pmtd_attributes = (copy_attributes pmtd_attributes); - Ast_410.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } -and copy_module_substitution : - Ast_409.Parsetree.module_substitution -> - Ast_410.Parsetree.module_substitution - = - fun - { Ast_409.Parsetree.pms_name = pms_name; - Ast_409.Parsetree.pms_manifest = pms_manifest; - Ast_409.Parsetree.pms_attributes = pms_attributes; - Ast_409.Parsetree.pms_loc = pms_loc } - -> - { - Ast_410.Parsetree.pms_name = (copy_loc (fun x -> x) pms_name); - Ast_410.Parsetree.pms_manifest = - (copy_loc copy_Longident_t pms_manifest); - Ast_410.Parsetree.pms_attributes = (copy_attributes pms_attributes); - Ast_410.Parsetree.pms_loc = (copy_location pms_loc) - } -and copy_module_declaration : - Ast_409.Parsetree.module_declaration -> - Ast_410.Parsetree.module_declaration - = - fun - { Ast_409.Parsetree.pmd_name = pmd_name; - Ast_409.Parsetree.pmd_type = pmd_type; - Ast_409.Parsetree.pmd_attributes = pmd_attributes; - Ast_409.Parsetree.pmd_loc = pmd_loc } - -> - { - Ast_410.Parsetree.pmd_name = (copy_loc (fun x -> Some x) pmd_name); - Ast_410.Parsetree.pmd_type = (copy_module_type pmd_type); - Ast_410.Parsetree.pmd_attributes = (copy_attributes pmd_attributes); - Ast_410.Parsetree.pmd_loc = (copy_location pmd_loc) - } -and copy_type_exception : - Ast_409.Parsetree.type_exception -> Ast_410.Parsetree.type_exception = - fun - { Ast_409.Parsetree.ptyexn_constructor = ptyexn_constructor; - Ast_409.Parsetree.ptyexn_loc = ptyexn_loc; - Ast_409.Parsetree.ptyexn_attributes = ptyexn_attributes } - -> - { - Ast_410.Parsetree.ptyexn_constructor = - (copy_extension_constructor ptyexn_constructor); - Ast_410.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); - Ast_410.Parsetree.ptyexn_attributes = - (copy_attributes ptyexn_attributes) - } -and copy_type_extension : - Ast_409.Parsetree.type_extension -> Ast_410.Parsetree.type_extension = - fun - { Ast_409.Parsetree.ptyext_path = ptyext_path; - Ast_409.Parsetree.ptyext_params = ptyext_params; - Ast_409.Parsetree.ptyext_constructors = ptyext_constructors; - Ast_409.Parsetree.ptyext_private = ptyext_private; - Ast_409.Parsetree.ptyext_loc = ptyext_loc; - Ast_409.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - Ast_410.Parsetree.ptyext_path = (copy_loc copy_Longident_t ptyext_path); - Ast_410.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - ptyext_params); - Ast_410.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor ptyext_constructors); - Ast_410.Parsetree.ptyext_private = (copy_private_flag ptyext_private); - Ast_410.Parsetree.ptyext_loc = (copy_location ptyext_loc); - Ast_410.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } -and copy_extension_constructor : - Ast_409.Parsetree.extension_constructor -> - Ast_410.Parsetree.extension_constructor - = - fun - { Ast_409.Parsetree.pext_name = pext_name; - Ast_409.Parsetree.pext_kind = pext_kind; - Ast_409.Parsetree.pext_loc = pext_loc; - Ast_409.Parsetree.pext_attributes = pext_attributes } - -> - { - Ast_410.Parsetree.pext_name = (copy_loc (fun x -> x) pext_name); - Ast_410.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - Ast_410.Parsetree.pext_loc = (copy_location pext_loc); - Ast_410.Parsetree.pext_attributes = (copy_attributes pext_attributes) - } -and copy_extension_constructor_kind : - Ast_409.Parsetree.extension_constructor_kind -> - Ast_410.Parsetree.extension_constructor_kind - = - function - | Ast_409.Parsetree.Pext_decl (x0, x1) -> - Ast_410.Parsetree.Pext_decl - ((copy_constructor_arguments x0), (map_option copy_core_type x1)) - | Ast_409.Parsetree.Pext_rebind x0 -> - Ast_410.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) -and copy_type_declaration : - Ast_409.Parsetree.type_declaration -> Ast_410.Parsetree.type_declaration = - fun - { Ast_409.Parsetree.ptype_name = ptype_name; - Ast_409.Parsetree.ptype_params = ptype_params; - Ast_409.Parsetree.ptype_cstrs = ptype_cstrs; - Ast_409.Parsetree.ptype_kind = ptype_kind; - Ast_409.Parsetree.ptype_private = ptype_private; - Ast_409.Parsetree.ptype_manifest = ptype_manifest; - Ast_409.Parsetree.ptype_attributes = ptype_attributes; - Ast_409.Parsetree.ptype_loc = ptype_loc } - -> - { - Ast_410.Parsetree.ptype_name = (copy_loc (fun x -> x) ptype_name); - Ast_410.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - ptype_params); - Ast_410.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0, x1, x2) = x in - ((copy_core_type x0), (copy_core_type x1), (copy_location x2))) - ptype_cstrs); - Ast_410.Parsetree.ptype_kind = (copy_type_kind ptype_kind); - Ast_410.Parsetree.ptype_private = (copy_private_flag ptype_private); - Ast_410.Parsetree.ptype_manifest = - (map_option copy_core_type ptype_manifest); - Ast_410.Parsetree.ptype_attributes = (copy_attributes ptype_attributes); - Ast_410.Parsetree.ptype_loc = (copy_location ptype_loc) - } -and copy_private_flag : - Ast_409.Asttypes.private_flag -> Ast_410.Asttypes.private_flag = - function - | Ast_409.Asttypes.Private -> Ast_410.Asttypes.Private - | Ast_409.Asttypes.Public -> Ast_410.Asttypes.Public -and copy_type_kind : - Ast_409.Parsetree.type_kind -> Ast_410.Parsetree.type_kind = - function - | Ast_409.Parsetree.Ptype_abstract -> Ast_410.Parsetree.Ptype_abstract - | Ast_409.Parsetree.Ptype_variant x0 -> - Ast_410.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | Ast_409.Parsetree.Ptype_record x0 -> - Ast_410.Parsetree.Ptype_record (List.map copy_label_declaration x0) - | Ast_409.Parsetree.Ptype_open -> Ast_410.Parsetree.Ptype_open -and copy_constructor_declaration : - Ast_409.Parsetree.constructor_declaration -> - Ast_410.Parsetree.constructor_declaration - = - fun - { Ast_409.Parsetree.pcd_name = pcd_name; - Ast_409.Parsetree.pcd_args = pcd_args; - Ast_409.Parsetree.pcd_res = pcd_res; - Ast_409.Parsetree.pcd_loc = pcd_loc; - Ast_409.Parsetree.pcd_attributes = pcd_attributes } - -> - { - Ast_410.Parsetree.pcd_name = (copy_loc (fun x -> x) pcd_name); - Ast_410.Parsetree.pcd_args = (copy_constructor_arguments pcd_args); - Ast_410.Parsetree.pcd_res = (map_option copy_core_type pcd_res); - Ast_410.Parsetree.pcd_loc = (copy_location pcd_loc); - Ast_410.Parsetree.pcd_attributes = (copy_attributes pcd_attributes) - } -and copy_constructor_arguments : - Ast_409.Parsetree.constructor_arguments -> - Ast_410.Parsetree.constructor_arguments - = - function - | Ast_409.Parsetree.Pcstr_tuple x0 -> - Ast_410.Parsetree.Pcstr_tuple (List.map copy_core_type x0) - | Ast_409.Parsetree.Pcstr_record x0 -> - Ast_410.Parsetree.Pcstr_record (List.map copy_label_declaration x0) -and copy_label_declaration : - Ast_409.Parsetree.label_declaration -> Ast_410.Parsetree.label_declaration - = - fun - { Ast_409.Parsetree.pld_name = pld_name; - Ast_409.Parsetree.pld_mutable = pld_mutable; - Ast_409.Parsetree.pld_type = pld_type; - Ast_409.Parsetree.pld_loc = pld_loc; - Ast_409.Parsetree.pld_attributes = pld_attributes } - -> - { - Ast_410.Parsetree.pld_name = (copy_loc (fun x -> x) pld_name); - Ast_410.Parsetree.pld_mutable = (copy_mutable_flag pld_mutable); - Ast_410.Parsetree.pld_type = (copy_core_type pld_type); - Ast_410.Parsetree.pld_loc = (copy_location pld_loc); - Ast_410.Parsetree.pld_attributes = (copy_attributes pld_attributes) - } -and copy_mutable_flag : - Ast_409.Asttypes.mutable_flag -> Ast_410.Asttypes.mutable_flag = - function - | Ast_409.Asttypes.Immutable -> Ast_410.Asttypes.Immutable - | Ast_409.Asttypes.Mutable -> Ast_410.Asttypes.Mutable -and copy_variance : Ast_409.Asttypes.variance -> Ast_410.Asttypes.variance = - function - | Ast_409.Asttypes.Covariant -> Ast_410.Asttypes.Covariant - | Ast_409.Asttypes.Contravariant -> Ast_410.Asttypes.Contravariant - | Ast_409.Asttypes.Invariant -> Ast_410.Asttypes.Invariant -and copy_value_description : - Ast_409.Parsetree.value_description -> Ast_410.Parsetree.value_description - = - fun - { Ast_409.Parsetree.pval_name = pval_name; - Ast_409.Parsetree.pval_type = pval_type; - Ast_409.Parsetree.pval_prim = pval_prim; - Ast_409.Parsetree.pval_attributes = pval_attributes; - Ast_409.Parsetree.pval_loc = pval_loc } - -> - { - Ast_410.Parsetree.pval_name = (copy_loc (fun x -> x) pval_name); - Ast_410.Parsetree.pval_type = (copy_core_type pval_type); - Ast_410.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - Ast_410.Parsetree.pval_attributes = (copy_attributes pval_attributes); - Ast_410.Parsetree.pval_loc = (copy_location pval_loc) - } -and copy_object_field_desc : - Ast_409.Parsetree.object_field_desc -> Ast_410.Parsetree.object_field_desc - = - function - | Ast_409.Parsetree.Otag (x0, x1) -> - Ast_410.Parsetree.Otag ((copy_loc copy_label x0), (copy_core_type x1)) - | Ast_409.Parsetree.Oinherit x0 -> - Ast_410.Parsetree.Oinherit (copy_core_type x0) -and copy_arg_label : Ast_409.Asttypes.arg_label -> Ast_410.Asttypes.arg_label - = - function - | Ast_409.Asttypes.Nolabel -> Ast_410.Asttypes.Nolabel - | Ast_409.Asttypes.Labelled x0 -> Ast_410.Asttypes.Labelled x0 - | Ast_409.Asttypes.Optional x0 -> Ast_410.Asttypes.Optional x0 -and copy_closed_flag : - Ast_409.Asttypes.closed_flag -> Ast_410.Asttypes.closed_flag = - function - | Ast_409.Asttypes.Closed -> Ast_410.Asttypes.Closed - | Ast_409.Asttypes.Open -> Ast_410.Asttypes.Open -and copy_label : Ast_409.Asttypes.label -> Ast_410.Asttypes.label = - fun x -> x -and copy_rec_flag : Ast_409.Asttypes.rec_flag -> Ast_410.Asttypes.rec_flag = - function - | Ast_409.Asttypes.Nonrecursive -> Ast_410.Asttypes.Nonrecursive - | Ast_409.Asttypes.Recursive -> Ast_410.Asttypes.Recursive -and copy_constant : Ast_409.Parsetree.constant -> Ast_410.Parsetree.constant - = - function - | Ast_409.Parsetree.Pconst_integer (x0, x1) -> - Ast_410.Parsetree.Pconst_integer (x0, (map_option (fun x -> x) x1)) - | Ast_409.Parsetree.Pconst_char x0 -> Ast_410.Parsetree.Pconst_char x0 - | Ast_409.Parsetree.Pconst_string (x0, x1) -> - Ast_410.Parsetree.Pconst_string (x0, (map_option (fun x -> x) x1)) - | Ast_409.Parsetree.Pconst_float (x0, x1) -> - Ast_410.Parsetree.Pconst_float (x0, (map_option (fun x -> x) x1)) -and copy_Longident_t : Ast_409.Longident.t -> Ast_410.Longident.t = - function - | Ast_409.Longident.Lident x0 -> Ast_410.Longident.Lident x0 - | Ast_409.Longident.Ldot (x0, x1) -> - Ast_410.Longident.Ldot ((copy_Longident_t x0), x1) - | Ast_409.Longident.Lapply (x0, x1) -> - Ast_410.Longident.Lapply ((copy_Longident_t x0), (copy_Longident_t x1)) -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 Ast_409.Asttypes.loc -> 'g0 Ast_410.Asttypes.loc - = - fun f0 -> - fun { Ast_409.Asttypes.txt = txt; Ast_409.Asttypes.loc = loc } -> - { - Ast_410.Asttypes.txt = (f0 txt); - Ast_410.Asttypes.loc = (copy_location loc) - } -and copy_location : Ast_409.Location.t -> Ast_410.Location.t = - fun - { Ast_409.Location.loc_start = loc_start; - Ast_409.Location.loc_end = loc_end; - Ast_409.Location.loc_ghost = loc_ghost } - -> - { - Ast_410.Location.loc_start = (copy_position loc_start); - Ast_410.Location.loc_end = (copy_position loc_end); - Ast_410.Location.loc_ghost = loc_ghost - } -and copy_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum - } -let copy_expr = copy_expression -let copy_pat = copy_pattern -let copy_typ = copy_core_type + { Ast_410.Outcometree.printed_name = printed_name } diff --git a/src/vendored-omp/src/migrate_parsetree_410_409.ml b/src/vendored-omp/src/migrate_parsetree_410_409.ml index ec7aae543..42576f02b 100644 --- a/src/vendored-omp/src/migrate_parsetree_410_409.ml +++ b/src/vendored-omp/src/migrate_parsetree_410_409.ml @@ -15,126 +15,3 @@ include Migrate_parsetree_410_409_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload"; - "binding_op"; "module_substitution"; "open_declaration"; "type_exception" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - binding_op; - module_substitution; - open_declaration; - type_exception; - (*$*) - } as mapper) -> - let module Def = Migrate_parsetree_def in - let module R = Migrate_parsetree_409_410_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - binding_op = (fun _ x -> copy_binding_op (binding_op mapper (R.copy_binding_op x))); - module_substitution = (fun _ x -> copy_module_substitution (module_substitution mapper (R.copy_module_substitution x))); - open_declaration = (fun _ x -> copy_open_declaration (open_declaration mapper (R.copy_open_declaration x))); - type_exception = (fun _ x -> copy_type_exception (type_exception mapper (R.copy_type_exception x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_410_409_migrate.ml b/src/vendored-omp/src/migrate_parsetree_410_409_migrate.ml index b57a859d2..28e123f63 100644 --- a/src/vendored-omp/src/migrate_parsetree_410_409_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_410_409_migrate.ml @@ -1,16 +1,13 @@ +open Stdlib0 module From = Ast_410 module To = Ast_409 + module Def = Migrate_parsetree_def let migration_error location feature = raise (Def.Migration_error (feature, location)) -let map_option f x = - match x with - | None -> None - | Some x -> Some (f x) - let rec copy_out_type_extension : Ast_410.Outcometree.out_type_extension -> Ast_409.Outcometree.out_type_extension @@ -30,7 +27,7 @@ let rec copy_out_type_extension : (fun x -> let (x0, x1, x2) = x in (x0, (List.map copy_out_type x1), - (map_option copy_out_type x2))) otyext_constructors); + (Option.map copy_out_type x2))) otyext_constructors); Ast_409.Outcometree.otyext_private = (copy_private_flag otyext_private) } and copy_out_phrase : @@ -43,7 +40,7 @@ and copy_out_phrase : (List.map (fun x -> let (x0, x1) = x in - ((copy_out_sig_item x0), (map_option copy_out_value x1))) x0) + ((copy_out_sig_item x0), (Option.map copy_out_value x1))) x0) | Ast_410.Outcometree.Ophr_exception x0 -> Ast_409.Outcometree.Ophr_exception (let (x0, x1) = x0 in (x0, (copy_out_value x1))) @@ -173,9 +170,14 @@ and copy_out_extension_constructor : (List.map (fun x -> x) oext_type_params); Ast_409.Outcometree.oext_args = (List.map copy_out_type oext_args); Ast_409.Outcometree.oext_ret_type = - (map_option copy_out_type oext_ret_type); + (Option.map copy_out_type oext_ret_type); Ast_409.Outcometree.oext_private = (copy_private_flag oext_private) } +and copy_private_flag : + Ast_410.Asttypes.private_flag -> Ast_409.Asttypes.private_flag = + function + | Ast_410.Asttypes.Private -> Ast_409.Asttypes.Private + | Ast_410.Asttypes.Public -> Ast_409.Asttypes.Public and copy_out_rec_status : Ast_410.Outcometree.out_rec_status -> Ast_409.Outcometree.out_rec_status = function @@ -193,7 +195,7 @@ and copy_out_class_type : (x0, (copy_out_type x1), (copy_out_class_type x2)) | Ast_410.Outcometree.Octy_signature (x0, x1) -> Ast_409.Outcometree.Octy_signature - ((map_option copy_out_type x0), + ((Option.map copy_out_type x0), (List.map copy_out_class_sig_item x1)) and copy_out_class_sig_item : Ast_410.Outcometree.out_class_sig_item -> @@ -229,7 +231,7 @@ and copy_out_type : | Ast_410.Outcometree.Otyp_object (x0, x1) -> Ast_409.Outcometree.Otyp_object ((List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) x0), - (map_option (fun x -> x) x1)) + (Option.map (fun x -> x) x1)) | Ast_410.Outcometree.Otyp_record x0 -> Ast_409.Outcometree.Otyp_record (List.map @@ -241,7 +243,7 @@ and copy_out_type : (fun x -> let (x0, x1, x2) = x in (x0, (List.map copy_out_type x1), - (map_option copy_out_type x2))) x0) + (Option.map copy_out_type x2))) x0) | Ast_410.Outcometree.Otyp_tuple x0 -> Ast_409.Outcometree.Otyp_tuple (List.map copy_out_type x0) | Ast_410.Outcometree.Otyp_var (x0, x1) -> @@ -249,7 +251,7 @@ and copy_out_type : | Ast_410.Outcometree.Otyp_variant (x0, x1, x2, x3) -> Ast_409.Outcometree.Otyp_variant (x0, (copy_out_variant x1), x2, - (map_option (fun x -> List.map (fun x -> x) x) x3)) + (Option.map (fun x -> List.map (fun x -> x) x) x3)) | Ast_410.Outcometree.Otyp_poly (x0, x1) -> Ast_409.Outcometree.Otyp_poly ((List.map (fun x -> x) x0), (copy_out_type x1)) @@ -307,7 +309,7 @@ and copy_out_value : | Ast_410.Outcometree.Oval_tuple x0 -> Ast_409.Outcometree.Oval_tuple (List.map copy_out_value x0) | Ast_410.Outcometree.Oval_variant (x0, x1) -> - Ast_409.Outcometree.Oval_variant (x0, (map_option copy_out_value x1)) + Ast_409.Outcometree.Oval_variant (x0, (Option.map copy_out_value x1)) and copy_out_string : Ast_410.Outcometree.out_string -> Ast_409.Outcometree.out_string = function @@ -327,1217 +329,3 @@ and copy_out_name : Ast_410.Outcometree.out_name -> Ast_409.Outcometree.out_name = fun { Ast_410.Outcometree.printed_name = printed_name } -> { Ast_409.Outcometree.printed_name = printed_name } -and copy_toplevel_phrase : - Ast_410.Parsetree.toplevel_phrase -> Ast_409.Parsetree.toplevel_phrase = - function - | Ast_410.Parsetree.Ptop_def x0 -> - Ast_409.Parsetree.Ptop_def (copy_structure x0) - | Ast_410.Parsetree.Ptop_dir x0 -> - Ast_409.Parsetree.Ptop_dir (copy_toplevel_directive x0) -and copy_toplevel_directive : - Ast_410.Parsetree.toplevel_directive -> - Ast_409.Parsetree.toplevel_directive - = - fun - { Ast_410.Parsetree.pdir_name = pdir_name; - Ast_410.Parsetree.pdir_arg = pdir_arg; - Ast_410.Parsetree.pdir_loc = pdir_loc } - -> - { - Ast_409.Parsetree.pdir_name = (copy_loc (fun x -> x) pdir_name); - Ast_409.Parsetree.pdir_arg = - (map_option copy_directive_argument pdir_arg); - Ast_409.Parsetree.pdir_loc = (copy_location pdir_loc) - } -and copy_directive_argument : - Ast_410.Parsetree.directive_argument -> - Ast_409.Parsetree.directive_argument - = - fun - { Ast_410.Parsetree.pdira_desc = pdira_desc; - Ast_410.Parsetree.pdira_loc = pdira_loc } - -> - { - Ast_409.Parsetree.pdira_desc = - (copy_directive_argument_desc pdira_desc); - Ast_409.Parsetree.pdira_loc = (copy_location pdira_loc) - } -and copy_directive_argument_desc : - Ast_410.Parsetree.directive_argument_desc -> - Ast_409.Parsetree.directive_argument_desc - = - function - | Ast_410.Parsetree.Pdir_string x0 -> Ast_409.Parsetree.Pdir_string x0 - | Ast_410.Parsetree.Pdir_int (x0, x1) -> - Ast_409.Parsetree.Pdir_int (x0, (map_option (fun x -> x) x1)) - | Ast_410.Parsetree.Pdir_ident x0 -> - Ast_409.Parsetree.Pdir_ident (copy_Longident_t x0) - | Ast_410.Parsetree.Pdir_bool x0 -> Ast_409.Parsetree.Pdir_bool x0 -and copy_expression : - Ast_410.Parsetree.expression -> Ast_409.Parsetree.expression = - fun - { Ast_410.Parsetree.pexp_desc = pexp_desc; - Ast_410.Parsetree.pexp_loc = pexp_loc; - Ast_410.Parsetree.pexp_loc_stack = pexp_loc_stack; - Ast_410.Parsetree.pexp_attributes = pexp_attributes } - -> - { - Ast_409.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - Ast_409.Parsetree.pexp_loc = (copy_location pexp_loc); - Ast_409.Parsetree.pexp_loc_stack = (copy_location_stack pexp_loc_stack); - Ast_409.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } -and copy_expression_desc : - Ast_410.Parsetree.expression_desc -> Ast_409.Parsetree.expression_desc = - function - | Ast_410.Parsetree.Pexp_ident x0 -> - Ast_409.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) - | Ast_410.Parsetree.Pexp_constant x0 -> - Ast_409.Parsetree.Pexp_constant (copy_constant x0) - | Ast_410.Parsetree.Pexp_let (x0, x1, x2) -> - Ast_409.Parsetree.Pexp_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_expression x2)) - | Ast_410.Parsetree.Pexp_function x0 -> - Ast_409.Parsetree.Pexp_function (List.map copy_case x0) - | Ast_410.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_409.Parsetree.Pexp_fun - ((copy_arg_label x0), (map_option copy_expression x1), - (copy_pattern x2), (copy_expression x3)) - | Ast_410.Parsetree.Pexp_apply (x0, x1) -> - Ast_409.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_410.Parsetree.Pexp_match (x0, x1) -> - Ast_409.Parsetree.Pexp_match - ((copy_expression x0), (List.map copy_case x1)) - | Ast_410.Parsetree.Pexp_try (x0, x1) -> - Ast_409.Parsetree.Pexp_try - ((copy_expression x0), (List.map copy_case x1)) - | Ast_410.Parsetree.Pexp_tuple x0 -> - Ast_409.Parsetree.Pexp_tuple (List.map copy_expression x0) - | Ast_410.Parsetree.Pexp_construct (x0, x1) -> - Ast_409.Parsetree.Pexp_construct - ((copy_loc copy_Longident_t x0), (map_option copy_expression x1)) - | Ast_410.Parsetree.Pexp_variant (x0, x1) -> - Ast_409.Parsetree.Pexp_variant - ((copy_label x0), (map_option copy_expression x1)) - | Ast_410.Parsetree.Pexp_record (x0, x1) -> - Ast_409.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_expression x1))) x0), - (map_option copy_expression x1)) - | Ast_410.Parsetree.Pexp_field (x0, x1) -> - Ast_409.Parsetree.Pexp_field - ((copy_expression x0), (copy_loc copy_Longident_t x1)) - | Ast_410.Parsetree.Pexp_setfield (x0, x1, x2) -> - Ast_409.Parsetree.Pexp_setfield - ((copy_expression x0), (copy_loc copy_Longident_t x1), - (copy_expression x2)) - | Ast_410.Parsetree.Pexp_array x0 -> - Ast_409.Parsetree.Pexp_array (List.map copy_expression x0) - | Ast_410.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> - Ast_409.Parsetree.Pexp_ifthenelse - ((copy_expression x0), (copy_expression x1), - (map_option copy_expression x2)) - | Ast_410.Parsetree.Pexp_sequence (x0, x1) -> - Ast_409.Parsetree.Pexp_sequence - ((copy_expression x0), (copy_expression x1)) - | Ast_410.Parsetree.Pexp_while (x0, x1) -> - Ast_409.Parsetree.Pexp_while - ((copy_expression x0), (copy_expression x1)) - | Ast_410.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> - Ast_409.Parsetree.Pexp_for - ((copy_pattern x0), (copy_expression x1), (copy_expression x2), - (copy_direction_flag x3), (copy_expression x4)) - | Ast_410.Parsetree.Pexp_constraint (x0, x1) -> - Ast_409.Parsetree.Pexp_constraint - ((copy_expression x0), (copy_core_type x1)) - | Ast_410.Parsetree.Pexp_coerce (x0, x1, x2) -> - Ast_409.Parsetree.Pexp_coerce - ((copy_expression x0), (map_option copy_core_type x1), - (copy_core_type x2)) - | Ast_410.Parsetree.Pexp_send (x0, x1) -> - Ast_409.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc copy_label x1)) - | Ast_410.Parsetree.Pexp_new x0 -> - Ast_409.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) - | Ast_410.Parsetree.Pexp_setinstvar (x0, x1) -> - Ast_409.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), (copy_expression x1)) - | Ast_410.Parsetree.Pexp_override x0 -> - Ast_409.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_label x0), (copy_expression x1))) x0) - | Ast_410.Parsetree.Pexp_letmodule (x0, x1, x2) -> - Ast_409.Parsetree.Pexp_letmodule - ((copy_loc (function - | None -> migration_error x0.loc Anonymous_let_module - | Some x -> x) x0), - (copy_module_expr x1), (copy_expression x2)) - | Ast_410.Parsetree.Pexp_letexception (x0, x1) -> - Ast_409.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), (copy_expression x1)) - | Ast_410.Parsetree.Pexp_assert x0 -> - Ast_409.Parsetree.Pexp_assert (copy_expression x0) - | Ast_410.Parsetree.Pexp_lazy x0 -> - Ast_409.Parsetree.Pexp_lazy (copy_expression x0) - | Ast_410.Parsetree.Pexp_poly (x0, x1) -> - Ast_409.Parsetree.Pexp_poly - ((copy_expression x0), (map_option copy_core_type x1)) - | Ast_410.Parsetree.Pexp_object x0 -> - Ast_409.Parsetree.Pexp_object (copy_class_structure x0) - | Ast_410.Parsetree.Pexp_newtype (x0, x1) -> - Ast_409.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | Ast_410.Parsetree.Pexp_pack x0 -> - Ast_409.Parsetree.Pexp_pack (copy_module_expr x0) - | Ast_410.Parsetree.Pexp_open (x0, x1) -> - Ast_409.Parsetree.Pexp_open - ((copy_open_declaration x0), (copy_expression x1)) - | Ast_410.Parsetree.Pexp_letop x0 -> - Ast_409.Parsetree.Pexp_letop (copy_letop x0) - | Ast_410.Parsetree.Pexp_extension x0 -> - Ast_409.Parsetree.Pexp_extension (copy_extension x0) - | Ast_410.Parsetree.Pexp_unreachable -> Ast_409.Parsetree.Pexp_unreachable -and copy_letop : Ast_410.Parsetree.letop -> Ast_409.Parsetree.letop = - fun - { Ast_410.Parsetree.let_ = let_; Ast_410.Parsetree.ands = ands; - Ast_410.Parsetree.body = body } - -> - { - Ast_409.Parsetree.let_ = (copy_binding_op let_); - Ast_409.Parsetree.ands = (List.map copy_binding_op ands); - Ast_409.Parsetree.body = (copy_expression body) - } -and copy_binding_op : - Ast_410.Parsetree.binding_op -> Ast_409.Parsetree.binding_op = - fun - { Ast_410.Parsetree.pbop_op = pbop_op; - Ast_410.Parsetree.pbop_pat = pbop_pat; - Ast_410.Parsetree.pbop_exp = pbop_exp; - Ast_410.Parsetree.pbop_loc = pbop_loc } - -> - { - Ast_409.Parsetree.pbop_op = (copy_loc (fun x -> x) pbop_op); - Ast_409.Parsetree.pbop_pat = (copy_pattern pbop_pat); - Ast_409.Parsetree.pbop_exp = (copy_expression pbop_exp); - Ast_409.Parsetree.pbop_loc = (copy_location pbop_loc) - } -and copy_direction_flag : - Ast_410.Asttypes.direction_flag -> Ast_409.Asttypes.direction_flag = - function - | Ast_410.Asttypes.Upto -> Ast_409.Asttypes.Upto - | Ast_410.Asttypes.Downto -> Ast_409.Asttypes.Downto -and copy_case : Ast_410.Parsetree.case -> Ast_409.Parsetree.case = - fun - { Ast_410.Parsetree.pc_lhs = pc_lhs; - Ast_410.Parsetree.pc_guard = pc_guard; - Ast_410.Parsetree.pc_rhs = pc_rhs } - -> - { - Ast_409.Parsetree.pc_lhs = (copy_pattern pc_lhs); - Ast_409.Parsetree.pc_guard = (map_option copy_expression pc_guard); - Ast_409.Parsetree.pc_rhs = (copy_expression pc_rhs) - } -and copy_cases : Ast_410.Parsetree.case list -> Ast_409.Parsetree.cases - = fun x -> List.map copy_case x -and copy_value_binding : - Ast_410.Parsetree.value_binding -> Ast_409.Parsetree.value_binding = - fun - { Ast_410.Parsetree.pvb_pat = pvb_pat; - Ast_410.Parsetree.pvb_expr = pvb_expr; - Ast_410.Parsetree.pvb_attributes = pvb_attributes; - Ast_410.Parsetree.pvb_loc = pvb_loc } - -> - { - Ast_409.Parsetree.pvb_pat = (copy_pattern pvb_pat); - Ast_409.Parsetree.pvb_expr = (copy_expression pvb_expr); - Ast_409.Parsetree.pvb_attributes = (copy_attributes pvb_attributes); - Ast_409.Parsetree.pvb_loc = (copy_location pvb_loc) - } -and copy_pattern : Ast_410.Parsetree.pattern -> Ast_409.Parsetree.pattern = - fun - { Ast_410.Parsetree.ppat_desc = ppat_desc; - Ast_410.Parsetree.ppat_loc = ppat_loc; - Ast_410.Parsetree.ppat_loc_stack = ppat_loc_stack; - Ast_410.Parsetree.ppat_attributes = ppat_attributes } - -> - { - Ast_409.Parsetree.ppat_desc = (copy_pattern_desc ppat_desc); - Ast_409.Parsetree.ppat_loc = (copy_location ppat_loc); - Ast_409.Parsetree.ppat_loc_stack = (copy_location_stack ppat_loc_stack); - Ast_409.Parsetree.ppat_attributes = (copy_attributes ppat_attributes) - } -and copy_pattern_desc : - Ast_410.Parsetree.pattern_desc -> Ast_409.Parsetree.pattern_desc = - function - | Ast_410.Parsetree.Ppat_any -> Ast_409.Parsetree.Ppat_any - | Ast_410.Parsetree.Ppat_var x0 -> - Ast_409.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | Ast_410.Parsetree.Ppat_alias (x0, x1) -> - Ast_409.Parsetree.Ppat_alias - ((copy_pattern x0), (copy_loc (fun x -> x) x1)) - | Ast_410.Parsetree.Ppat_constant x0 -> - Ast_409.Parsetree.Ppat_constant (copy_constant x0) - | Ast_410.Parsetree.Ppat_interval (x0, x1) -> - Ast_409.Parsetree.Ppat_interval - ((copy_constant x0), (copy_constant x1)) - | Ast_410.Parsetree.Ppat_tuple x0 -> - Ast_409.Parsetree.Ppat_tuple (List.map copy_pattern x0) - | Ast_410.Parsetree.Ppat_construct (x0, x1) -> - Ast_409.Parsetree.Ppat_construct - ((copy_loc copy_Longident_t x0), (map_option copy_pattern x1)) - | Ast_410.Parsetree.Ppat_variant (x0, x1) -> - Ast_409.Parsetree.Ppat_variant - ((copy_label x0), (map_option copy_pattern x1)) - | Ast_410.Parsetree.Ppat_record (x0, x1) -> - Ast_409.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | Ast_410.Parsetree.Ppat_array x0 -> - Ast_409.Parsetree.Ppat_array (List.map copy_pattern x0) - | Ast_410.Parsetree.Ppat_or (x0, x1) -> - Ast_409.Parsetree.Ppat_or ((copy_pattern x0), (copy_pattern x1)) - | Ast_410.Parsetree.Ppat_constraint (x0, x1) -> - Ast_409.Parsetree.Ppat_constraint - ((copy_pattern x0), (copy_core_type x1)) - | Ast_410.Parsetree.Ppat_type x0 -> - Ast_409.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) - | Ast_410.Parsetree.Ppat_lazy x0 -> - Ast_409.Parsetree.Ppat_lazy (copy_pattern x0) - | Ast_410.Parsetree.Ppat_unpack x0 -> - Ast_409.Parsetree.Ppat_unpack - (copy_loc (function - | None -> migration_error x0.loc Anonymous_unpack - | Some x -> x) x0) - | Ast_410.Parsetree.Ppat_exception x0 -> - Ast_409.Parsetree.Ppat_exception (copy_pattern x0) - | Ast_410.Parsetree.Ppat_extension x0 -> - Ast_409.Parsetree.Ppat_extension (copy_extension x0) - | Ast_410.Parsetree.Ppat_open (x0, x1) -> - Ast_409.Parsetree.Ppat_open - ((copy_loc copy_Longident_t x0), (copy_pattern x1)) -and copy_core_type : - Ast_410.Parsetree.core_type -> Ast_409.Parsetree.core_type = - fun - { Ast_410.Parsetree.ptyp_desc = ptyp_desc; - Ast_410.Parsetree.ptyp_loc = ptyp_loc; - Ast_410.Parsetree.ptyp_loc_stack = ptyp_loc_stack; - Ast_410.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - Ast_409.Parsetree.ptyp_desc = (copy_core_type_desc ptyp_desc); - Ast_409.Parsetree.ptyp_loc = (copy_location ptyp_loc); - Ast_409.Parsetree.ptyp_loc_stack = (copy_location_stack ptyp_loc_stack); - Ast_409.Parsetree.ptyp_attributes = (copy_attributes ptyp_attributes) - } -and copy_location_stack : - Ast_410.Parsetree.location_stack -> Ast_409.Location.t list = - fun x -> List.map copy_location x -and copy_core_type_desc : - Ast_410.Parsetree.core_type_desc -> Ast_409.Parsetree.core_type_desc = - function - | Ast_410.Parsetree.Ptyp_any -> Ast_409.Parsetree.Ptyp_any - | Ast_410.Parsetree.Ptyp_var x0 -> Ast_409.Parsetree.Ptyp_var x0 - | Ast_410.Parsetree.Ptyp_arrow (x0, x1, x2) -> - Ast_409.Parsetree.Ptyp_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_core_type x2)) - | Ast_410.Parsetree.Ptyp_tuple x0 -> - Ast_409.Parsetree.Ptyp_tuple (List.map copy_core_type x0) - | Ast_410.Parsetree.Ptyp_constr (x0, x1) -> - Ast_409.Parsetree.Ptyp_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_410.Parsetree.Ptyp_object (x0, x1) -> - Ast_409.Parsetree.Ptyp_object - ((List.map copy_object_field x0), (copy_closed_flag x1)) - | Ast_410.Parsetree.Ptyp_class (x0, x1) -> - Ast_409.Parsetree.Ptyp_class - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_410.Parsetree.Ptyp_alias (x0, x1) -> - Ast_409.Parsetree.Ptyp_alias ((copy_core_type x0), x1) - | Ast_410.Parsetree.Ptyp_variant (x0, x1, x2) -> - Ast_409.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), (copy_closed_flag x1), - (map_option (fun x -> List.map copy_label x) x2)) - | Ast_410.Parsetree.Ptyp_poly (x0, x1) -> - Ast_409.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | Ast_410.Parsetree.Ptyp_package x0 -> - Ast_409.Parsetree.Ptyp_package (copy_package_type x0) - | Ast_410.Parsetree.Ptyp_extension x0 -> - Ast_409.Parsetree.Ptyp_extension (copy_extension x0) -and copy_package_type : - Ast_410.Parsetree.package_type -> Ast_409.Parsetree.package_type = - fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_core_type x1))) x1)) -and copy_row_field : - Ast_410.Parsetree.row_field -> Ast_409.Parsetree.row_field = - fun - { Ast_410.Parsetree.prf_desc = prf_desc; - Ast_410.Parsetree.prf_loc = prf_loc; - Ast_410.Parsetree.prf_attributes = prf_attributes } - -> - { - Ast_409.Parsetree.prf_desc = (copy_row_field_desc prf_desc); - Ast_409.Parsetree.prf_loc = (copy_location prf_loc); - Ast_409.Parsetree.prf_attributes = (copy_attributes prf_attributes) - } -and copy_row_field_desc : - Ast_410.Parsetree.row_field_desc -> Ast_409.Parsetree.row_field_desc = - function - | Ast_410.Parsetree.Rtag (x0, x1, x2) -> - Ast_409.Parsetree.Rtag - ((copy_loc copy_label x0), x1, (List.map copy_core_type x2)) - | Ast_410.Parsetree.Rinherit x0 -> - Ast_409.Parsetree.Rinherit (copy_core_type x0) -and copy_object_field : - Ast_410.Parsetree.object_field -> Ast_409.Parsetree.object_field = - fun - { Ast_410.Parsetree.pof_desc = pof_desc; - Ast_410.Parsetree.pof_loc = pof_loc; - Ast_410.Parsetree.pof_attributes = pof_attributes } - -> - { - Ast_409.Parsetree.pof_desc = (copy_object_field_desc pof_desc); - Ast_409.Parsetree.pof_loc = (copy_location pof_loc); - Ast_409.Parsetree.pof_attributes = (copy_attributes pof_attributes) - } -and copy_attributes : - Ast_410.Parsetree.attributes -> Ast_409.Parsetree.attributes = - fun x -> List.map copy_attribute x -and copy_attribute : - Ast_410.Parsetree.attribute -> Ast_409.Parsetree.attribute = - fun - { Ast_410.Parsetree.attr_name = attr_name; - Ast_410.Parsetree.attr_payload = attr_payload; - Ast_410.Parsetree.attr_loc = attr_loc } - -> - { - Ast_409.Parsetree.attr_name = (copy_loc (fun x -> x) attr_name); - Ast_409.Parsetree.attr_payload = (copy_payload attr_payload); - Ast_409.Parsetree.attr_loc = (copy_location attr_loc) - } -and copy_payload : Ast_410.Parsetree.payload -> Ast_409.Parsetree.payload = - function - | Ast_410.Parsetree.PStr x0 -> Ast_409.Parsetree.PStr (copy_structure x0) - | Ast_410.Parsetree.PSig x0 -> Ast_409.Parsetree.PSig (copy_signature x0) - | Ast_410.Parsetree.PTyp x0 -> Ast_409.Parsetree.PTyp (copy_core_type x0) - | Ast_410.Parsetree.PPat (x0, x1) -> - Ast_409.Parsetree.PPat - ((copy_pattern x0), (map_option copy_expression x1)) -and copy_structure : - Ast_410.Parsetree.structure -> Ast_409.Parsetree.structure = - fun x -> List.map copy_structure_item x -and copy_structure_item : - Ast_410.Parsetree.structure_item -> Ast_409.Parsetree.structure_item = - fun - { Ast_410.Parsetree.pstr_desc = pstr_desc; - Ast_410.Parsetree.pstr_loc = pstr_loc } - -> - { - Ast_409.Parsetree.pstr_desc = (copy_structure_item_desc pstr_desc); - Ast_409.Parsetree.pstr_loc = (copy_location pstr_loc) - } -and copy_structure_item_desc : - Ast_410.Parsetree.structure_item_desc -> - Ast_409.Parsetree.structure_item_desc - = - function - | Ast_410.Parsetree.Pstr_eval (x0, x1) -> - Ast_409.Parsetree.Pstr_eval - ((copy_expression x0), (copy_attributes x1)) - | Ast_410.Parsetree.Pstr_value (x0, x1) -> - Ast_409.Parsetree.Pstr_value - ((copy_rec_flag x0), (List.map copy_value_binding x1)) - | Ast_410.Parsetree.Pstr_primitive x0 -> - Ast_409.Parsetree.Pstr_primitive (copy_value_description x0) - | Ast_410.Parsetree.Pstr_type (x0, x1) -> - Ast_409.Parsetree.Pstr_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_410.Parsetree.Pstr_typext x0 -> - Ast_409.Parsetree.Pstr_typext (copy_type_extension x0) - | Ast_410.Parsetree.Pstr_exception x0 -> - Ast_409.Parsetree.Pstr_exception (copy_type_exception x0) - | Ast_410.Parsetree.Pstr_module x0 -> - Ast_409.Parsetree.Pstr_module (copy_module_binding x0) - | Ast_410.Parsetree.Pstr_recmodule x0 -> - Ast_409.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) - | Ast_410.Parsetree.Pstr_modtype x0 -> - Ast_409.Parsetree.Pstr_modtype (copy_module_type_declaration x0) - | Ast_410.Parsetree.Pstr_open x0 -> - Ast_409.Parsetree.Pstr_open (copy_open_declaration x0) - | Ast_410.Parsetree.Pstr_class x0 -> - Ast_409.Parsetree.Pstr_class (List.map copy_class_declaration x0) - | Ast_410.Parsetree.Pstr_class_type x0 -> - Ast_409.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | Ast_410.Parsetree.Pstr_include x0 -> - Ast_409.Parsetree.Pstr_include (copy_include_declaration x0) - | Ast_410.Parsetree.Pstr_attribute x0 -> - Ast_409.Parsetree.Pstr_attribute (copy_attribute x0) - | Ast_410.Parsetree.Pstr_extension (x0, x1) -> - Ast_409.Parsetree.Pstr_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_include_declaration : - Ast_410.Parsetree.include_declaration -> - Ast_409.Parsetree.include_declaration - = fun x -> copy_include_infos copy_module_expr x -and copy_class_declaration : - Ast_410.Parsetree.class_declaration -> Ast_409.Parsetree.class_declaration - = fun x -> copy_class_infos copy_class_expr x -and copy_class_expr : - Ast_410.Parsetree.class_expr -> Ast_409.Parsetree.class_expr = - fun - { Ast_410.Parsetree.pcl_desc = pcl_desc; - Ast_410.Parsetree.pcl_loc = pcl_loc; - Ast_410.Parsetree.pcl_attributes = pcl_attributes } - -> - { - Ast_409.Parsetree.pcl_desc = (copy_class_expr_desc pcl_desc); - Ast_409.Parsetree.pcl_loc = (copy_location pcl_loc); - Ast_409.Parsetree.pcl_attributes = (copy_attributes pcl_attributes) - } -and copy_class_expr_desc : - Ast_410.Parsetree.class_expr_desc -> Ast_409.Parsetree.class_expr_desc = - function - | Ast_410.Parsetree.Pcl_constr (x0, x1) -> - Ast_409.Parsetree.Pcl_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_410.Parsetree.Pcl_structure x0 -> - Ast_409.Parsetree.Pcl_structure (copy_class_structure x0) - | Ast_410.Parsetree.Pcl_fun (x0, x1, x2, x3) -> - Ast_409.Parsetree.Pcl_fun - ((copy_arg_label x0), (map_option copy_expression x1), - (copy_pattern x2), (copy_class_expr x3)) - | Ast_410.Parsetree.Pcl_apply (x0, x1) -> - Ast_409.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_410.Parsetree.Pcl_let (x0, x1, x2) -> - Ast_409.Parsetree.Pcl_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_class_expr x2)) - | Ast_410.Parsetree.Pcl_constraint (x0, x1) -> - Ast_409.Parsetree.Pcl_constraint - ((copy_class_expr x0), (copy_class_type x1)) - | Ast_410.Parsetree.Pcl_extension x0 -> - Ast_409.Parsetree.Pcl_extension (copy_extension x0) - | Ast_410.Parsetree.Pcl_open (x0, x1) -> - Ast_409.Parsetree.Pcl_open - ((copy_open_description x0), (copy_class_expr x1)) -and copy_class_structure : - Ast_410.Parsetree.class_structure -> Ast_409.Parsetree.class_structure = - fun - { Ast_410.Parsetree.pcstr_self = pcstr_self; - Ast_410.Parsetree.pcstr_fields = pcstr_fields } - -> - { - Ast_409.Parsetree.pcstr_self = (copy_pattern pcstr_self); - Ast_409.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } -and copy_class_field : - Ast_410.Parsetree.class_field -> Ast_409.Parsetree.class_field = - fun - { Ast_410.Parsetree.pcf_desc = pcf_desc; - Ast_410.Parsetree.pcf_loc = pcf_loc; - Ast_410.Parsetree.pcf_attributes = pcf_attributes } - -> - { - Ast_409.Parsetree.pcf_desc = (copy_class_field_desc pcf_desc); - Ast_409.Parsetree.pcf_loc = (copy_location pcf_loc); - Ast_409.Parsetree.pcf_attributes = (copy_attributes pcf_attributes) - } -and copy_class_field_desc : - Ast_410.Parsetree.class_field_desc -> Ast_409.Parsetree.class_field_desc = - function - | Ast_410.Parsetree.Pcf_inherit (x0, x1, x2) -> - Ast_409.Parsetree.Pcf_inherit - ((copy_override_flag x0), (copy_class_expr x1), - (map_option (fun x -> copy_loc (fun x -> x) x) x2)) - | Ast_410.Parsetree.Pcf_val x0 -> - Ast_409.Parsetree.Pcf_val - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | Ast_410.Parsetree.Pcf_method x0 -> - Ast_409.Parsetree.Pcf_method - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_class_field_kind x2))) - | Ast_410.Parsetree.Pcf_constraint x0 -> - Ast_409.Parsetree.Pcf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_410.Parsetree.Pcf_initializer x0 -> - Ast_409.Parsetree.Pcf_initializer (copy_expression x0) - | Ast_410.Parsetree.Pcf_attribute x0 -> - Ast_409.Parsetree.Pcf_attribute (copy_attribute x0) - | Ast_410.Parsetree.Pcf_extension x0 -> - Ast_409.Parsetree.Pcf_extension (copy_extension x0) -and copy_class_field_kind : - Ast_410.Parsetree.class_field_kind -> Ast_409.Parsetree.class_field_kind = - function - | Ast_410.Parsetree.Cfk_virtual x0 -> - Ast_409.Parsetree.Cfk_virtual (copy_core_type x0) - | Ast_410.Parsetree.Cfk_concrete (x0, x1) -> - Ast_409.Parsetree.Cfk_concrete - ((copy_override_flag x0), (copy_expression x1)) -and copy_open_declaration : - Ast_410.Parsetree.open_declaration -> Ast_409.Parsetree.open_declaration = - fun x -> copy_open_infos copy_module_expr x -and copy_module_binding : - Ast_410.Parsetree.module_binding -> Ast_409.Parsetree.module_binding = - fun - { Ast_410.Parsetree.pmb_name = pmb_name; - Ast_410.Parsetree.pmb_expr = pmb_expr; - Ast_410.Parsetree.pmb_attributes = pmb_attributes; - Ast_410.Parsetree.pmb_loc = pmb_loc } - -> - { - Ast_409.Parsetree.pmb_name = - (copy_loc (function Some x -> x - | None -> migration_error pmb_name.loc Anonymous_module_binding) pmb_name); - Ast_409.Parsetree.pmb_expr = (copy_module_expr pmb_expr); - Ast_409.Parsetree.pmb_attributes = (copy_attributes pmb_attributes); - Ast_409.Parsetree.pmb_loc = (copy_location pmb_loc) - } -and copy_module_expr : - Ast_410.Parsetree.module_expr -> Ast_409.Parsetree.module_expr = - fun - { Ast_410.Parsetree.pmod_desc = pmod_desc; - Ast_410.Parsetree.pmod_loc = pmod_loc; - Ast_410.Parsetree.pmod_attributes = pmod_attributes } - -> - { - Ast_409.Parsetree.pmod_desc = (copy_module_expr_desc pmod_desc); - Ast_409.Parsetree.pmod_loc = (copy_location pmod_loc); - Ast_409.Parsetree.pmod_attributes = (copy_attributes pmod_attributes) - } -and copy_module_expr_desc : - Ast_410.Parsetree.module_expr_desc -> Ast_409.Parsetree.module_expr_desc = - function - | Ast_410.Parsetree.Pmod_ident x0 -> - Ast_409.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) - | Ast_410.Parsetree.Pmod_structure x0 -> - Ast_409.Parsetree.Pmod_structure (copy_structure x0) - | Ast_410.Parsetree.Pmod_functor (x0, x1) -> - let x, y = copy_functor_parameter x0 in - Ast_409.Parsetree.Pmod_functor - (x, y, (copy_module_expr x1)) - | Ast_410.Parsetree.Pmod_apply (x0, x1) -> - Ast_409.Parsetree.Pmod_apply - ((copy_module_expr x0), (copy_module_expr x1)) - | Ast_410.Parsetree.Pmod_constraint (x0, x1) -> - Ast_409.Parsetree.Pmod_constraint - ((copy_module_expr x0), (copy_module_type x1)) - | Ast_410.Parsetree.Pmod_unpack x0 -> - Ast_409.Parsetree.Pmod_unpack (copy_expression x0) - | Ast_410.Parsetree.Pmod_extension x0 -> - Ast_409.Parsetree.Pmod_extension (copy_extension x0) -and copy_functor_parameter : - Ast_410.Parsetree.functor_parameter -> string Ast_409.Asttypes.loc * Ast_409.Parsetree.module_type option - = - function - | Ast_410.Parsetree.Unit -> ({ loc = Location.none; txt = "*" }, None) - | Ast_410.Parsetree.Named (x0, x1) -> - ((copy_loc (function - | None -> "_" - | Some x -> x) x0, - Some (copy_module_type x1))) -and copy_module_type : - Ast_410.Parsetree.module_type -> Ast_409.Parsetree.module_type = - fun - { Ast_410.Parsetree.pmty_desc = pmty_desc; - Ast_410.Parsetree.pmty_loc = pmty_loc; - Ast_410.Parsetree.pmty_attributes = pmty_attributes } - -> - { - Ast_409.Parsetree.pmty_desc = (copy_module_type_desc pmty_desc); - Ast_409.Parsetree.pmty_loc = (copy_location pmty_loc); - Ast_409.Parsetree.pmty_attributes = (copy_attributes pmty_attributes) - } -and copy_module_type_desc : - Ast_410.Parsetree.module_type_desc -> Ast_409.Parsetree.module_type_desc = - function - | Ast_410.Parsetree.Pmty_ident x0 -> - Ast_409.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) - | Ast_410.Parsetree.Pmty_signature x0 -> - Ast_409.Parsetree.Pmty_signature (copy_signature x0) - | Ast_410.Parsetree.Pmty_functor (x0, x1) -> - let x, y = copy_functor_parameter x0 in - Ast_409.Parsetree.Pmty_functor - (x, y, (copy_module_type x1)) - | Ast_410.Parsetree.Pmty_with (x0, x1) -> - Ast_409.Parsetree.Pmty_with - ((copy_module_type x0), (List.map copy_with_constraint x1)) - | Ast_410.Parsetree.Pmty_typeof x0 -> - Ast_409.Parsetree.Pmty_typeof (copy_module_expr x0) - | Ast_410.Parsetree.Pmty_extension x0 -> - Ast_409.Parsetree.Pmty_extension (copy_extension x0) - | Ast_410.Parsetree.Pmty_alias x0 -> - Ast_409.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) -and copy_with_constraint : - Ast_410.Parsetree.with_constraint -> Ast_409.Parsetree.with_constraint = - function - | Ast_410.Parsetree.Pwith_type (x0, x1) -> - Ast_409.Parsetree.Pwith_type - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_410.Parsetree.Pwith_module (x0, x1) -> - Ast_409.Parsetree.Pwith_module - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) - | Ast_410.Parsetree.Pwith_typesubst (x0, x1) -> - Ast_409.Parsetree.Pwith_typesubst - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_410.Parsetree.Pwith_modsubst (x0, x1) -> - Ast_409.Parsetree.Pwith_modsubst - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) -and copy_signature : - Ast_410.Parsetree.signature -> Ast_409.Parsetree.signature = - fun x -> List.map copy_signature_item x -and copy_signature_item : - Ast_410.Parsetree.signature_item -> Ast_409.Parsetree.signature_item = - fun - { Ast_410.Parsetree.psig_desc = psig_desc; - Ast_410.Parsetree.psig_loc = psig_loc } - -> - { - Ast_409.Parsetree.psig_desc = (copy_signature_item_desc psig_desc); - Ast_409.Parsetree.psig_loc = (copy_location psig_loc) - } -and copy_signature_item_desc : - Ast_410.Parsetree.signature_item_desc -> - Ast_409.Parsetree.signature_item_desc - = - function - | Ast_410.Parsetree.Psig_value x0 -> - Ast_409.Parsetree.Psig_value (copy_value_description x0) - | Ast_410.Parsetree.Psig_type (x0, x1) -> - Ast_409.Parsetree.Psig_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_410.Parsetree.Psig_typesubst x0 -> - Ast_409.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) - | Ast_410.Parsetree.Psig_typext x0 -> - Ast_409.Parsetree.Psig_typext (copy_type_extension x0) - | Ast_410.Parsetree.Psig_exception x0 -> - Ast_409.Parsetree.Psig_exception (copy_type_exception x0) - | Ast_410.Parsetree.Psig_module x0 -> - Ast_409.Parsetree.Psig_module (copy_module_declaration x0) - | Ast_410.Parsetree.Psig_modsubst x0 -> - Ast_409.Parsetree.Psig_modsubst (copy_module_substitution x0) - | Ast_410.Parsetree.Psig_recmodule x0 -> - Ast_409.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) - | Ast_410.Parsetree.Psig_modtype x0 -> - Ast_409.Parsetree.Psig_modtype (copy_module_type_declaration x0) - | Ast_410.Parsetree.Psig_open x0 -> - Ast_409.Parsetree.Psig_open (copy_open_description x0) - | Ast_410.Parsetree.Psig_include x0 -> - Ast_409.Parsetree.Psig_include (copy_include_description x0) - | Ast_410.Parsetree.Psig_class x0 -> - Ast_409.Parsetree.Psig_class (List.map copy_class_description x0) - | Ast_410.Parsetree.Psig_class_type x0 -> - Ast_409.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | Ast_410.Parsetree.Psig_attribute x0 -> - Ast_409.Parsetree.Psig_attribute (copy_attribute x0) - | Ast_410.Parsetree.Psig_extension (x0, x1) -> - Ast_409.Parsetree.Psig_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_class_type_declaration : - Ast_410.Parsetree.class_type_declaration -> - Ast_409.Parsetree.class_type_declaration - = fun x -> copy_class_infos copy_class_type x -and copy_class_description : - Ast_410.Parsetree.class_description -> Ast_409.Parsetree.class_description - = fun x -> copy_class_infos copy_class_type x -and copy_class_type : - Ast_410.Parsetree.class_type -> Ast_409.Parsetree.class_type = - fun - { Ast_410.Parsetree.pcty_desc = pcty_desc; - Ast_410.Parsetree.pcty_loc = pcty_loc; - Ast_410.Parsetree.pcty_attributes = pcty_attributes } - -> - { - Ast_409.Parsetree.pcty_desc = (copy_class_type_desc pcty_desc); - Ast_409.Parsetree.pcty_loc = (copy_location pcty_loc); - Ast_409.Parsetree.pcty_attributes = (copy_attributes pcty_attributes) - } -and copy_class_type_desc : - Ast_410.Parsetree.class_type_desc -> Ast_409.Parsetree.class_type_desc = - function - | Ast_410.Parsetree.Pcty_constr (x0, x1) -> - Ast_409.Parsetree.Pcty_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_410.Parsetree.Pcty_signature x0 -> - Ast_409.Parsetree.Pcty_signature (copy_class_signature x0) - | Ast_410.Parsetree.Pcty_arrow (x0, x1, x2) -> - Ast_409.Parsetree.Pcty_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_class_type x2)) - | Ast_410.Parsetree.Pcty_extension x0 -> - Ast_409.Parsetree.Pcty_extension (copy_extension x0) - | Ast_410.Parsetree.Pcty_open (x0, x1) -> - Ast_409.Parsetree.Pcty_open - ((copy_open_description x0), (copy_class_type x1)) -and copy_class_signature : - Ast_410.Parsetree.class_signature -> Ast_409.Parsetree.class_signature = - fun - { Ast_410.Parsetree.pcsig_self = pcsig_self; - Ast_410.Parsetree.pcsig_fields = pcsig_fields } - -> - { - Ast_409.Parsetree.pcsig_self = (copy_core_type pcsig_self); - Ast_409.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } -and copy_class_type_field : - Ast_410.Parsetree.class_type_field -> Ast_409.Parsetree.class_type_field = - fun - { Ast_410.Parsetree.pctf_desc = pctf_desc; - Ast_410.Parsetree.pctf_loc = pctf_loc; - Ast_410.Parsetree.pctf_attributes = pctf_attributes } - -> - { - Ast_409.Parsetree.pctf_desc = (copy_class_type_field_desc pctf_desc); - Ast_409.Parsetree.pctf_loc = (copy_location pctf_loc); - Ast_409.Parsetree.pctf_attributes = (copy_attributes pctf_attributes) - } -and copy_class_type_field_desc : - Ast_410.Parsetree.class_type_field_desc -> - Ast_409.Parsetree.class_type_field_desc - = - function - | Ast_410.Parsetree.Pctf_inherit x0 -> - Ast_409.Parsetree.Pctf_inherit (copy_class_type x0) - | Ast_410.Parsetree.Pctf_val x0 -> - Ast_409.Parsetree.Pctf_val - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_410.Parsetree.Pctf_method x0 -> - Ast_409.Parsetree.Pctf_method - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_410.Parsetree.Pctf_constraint x0 -> - Ast_409.Parsetree.Pctf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_410.Parsetree.Pctf_attribute x0 -> - Ast_409.Parsetree.Pctf_attribute (copy_attribute x0) - | Ast_410.Parsetree.Pctf_extension x0 -> - Ast_409.Parsetree.Pctf_extension (copy_extension x0) -and copy_extension : - Ast_410.Parsetree.extension -> Ast_409.Parsetree.extension = - fun x -> - let (x0, x1) = x in ((copy_loc (fun x -> x) x0), (copy_payload x1)) -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_410.Parsetree.class_infos -> 'g0 Ast_409.Parsetree.class_infos - = - fun f0 -> - fun - { Ast_410.Parsetree.pci_virt = pci_virt; - Ast_410.Parsetree.pci_params = pci_params; - Ast_410.Parsetree.pci_name = pci_name; - Ast_410.Parsetree.pci_expr = pci_expr; - Ast_410.Parsetree.pci_loc = pci_loc; - Ast_410.Parsetree.pci_attributes = pci_attributes } - -> - { - Ast_409.Parsetree.pci_virt = (copy_virtual_flag pci_virt); - Ast_409.Parsetree.pci_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - pci_params); - Ast_409.Parsetree.pci_name = (copy_loc (fun x -> x) pci_name); - Ast_409.Parsetree.pci_expr = (f0 pci_expr); - Ast_409.Parsetree.pci_loc = (copy_location pci_loc); - Ast_409.Parsetree.pci_attributes = (copy_attributes pci_attributes) - } -and copy_virtual_flag : - Ast_410.Asttypes.virtual_flag -> Ast_409.Asttypes.virtual_flag = - function - | Ast_410.Asttypes.Virtual -> Ast_409.Asttypes.Virtual - | Ast_410.Asttypes.Concrete -> Ast_409.Asttypes.Concrete -and copy_include_description : - Ast_410.Parsetree.include_description -> - Ast_409.Parsetree.include_description - = fun x -> copy_include_infos copy_module_type x -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_410.Parsetree.include_infos -> - 'g0 Ast_409.Parsetree.include_infos - = - fun f0 -> - fun - { Ast_410.Parsetree.pincl_mod = pincl_mod; - Ast_410.Parsetree.pincl_loc = pincl_loc; - Ast_410.Parsetree.pincl_attributes = pincl_attributes } - -> - { - Ast_409.Parsetree.pincl_mod = (f0 pincl_mod); - Ast_409.Parsetree.pincl_loc = (copy_location pincl_loc); - Ast_409.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } -and copy_open_description : - Ast_410.Parsetree.open_description -> Ast_409.Parsetree.open_description = - fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x -and copy_open_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_410.Parsetree.open_infos -> 'g0 Ast_409.Parsetree.open_infos - = - fun f0 -> - fun - { Ast_410.Parsetree.popen_expr = popen_expr; - Ast_410.Parsetree.popen_override = popen_override; - Ast_410.Parsetree.popen_loc = popen_loc; - Ast_410.Parsetree.popen_attributes = popen_attributes } - -> - { - Ast_409.Parsetree.popen_expr = (f0 popen_expr); - Ast_409.Parsetree.popen_override = - (copy_override_flag popen_override); - Ast_409.Parsetree.popen_loc = (copy_location popen_loc); - Ast_409.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } -and copy_override_flag : - Ast_410.Asttypes.override_flag -> Ast_409.Asttypes.override_flag = - function - | Ast_410.Asttypes.Override -> Ast_409.Asttypes.Override - | Ast_410.Asttypes.Fresh -> Ast_409.Asttypes.Fresh -and copy_module_type_declaration : - Ast_410.Parsetree.module_type_declaration -> - Ast_409.Parsetree.module_type_declaration - = - fun - { Ast_410.Parsetree.pmtd_name = pmtd_name; - Ast_410.Parsetree.pmtd_type = pmtd_type; - Ast_410.Parsetree.pmtd_attributes = pmtd_attributes; - Ast_410.Parsetree.pmtd_loc = pmtd_loc } - -> - { - Ast_409.Parsetree.pmtd_name = (copy_loc (fun x -> x) pmtd_name); - Ast_409.Parsetree.pmtd_type = (map_option copy_module_type pmtd_type); - Ast_409.Parsetree.pmtd_attributes = (copy_attributes pmtd_attributes); - Ast_409.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } -and copy_module_substitution : - Ast_410.Parsetree.module_substitution -> - Ast_409.Parsetree.module_substitution - = - fun - { Ast_410.Parsetree.pms_name = pms_name; - Ast_410.Parsetree.pms_manifest = pms_manifest; - Ast_410.Parsetree.pms_attributes = pms_attributes; - Ast_410.Parsetree.pms_loc = pms_loc } - -> - { - Ast_409.Parsetree.pms_name = (copy_loc (fun x -> x) pms_name); - Ast_409.Parsetree.pms_manifest = - (copy_loc copy_Longident_t pms_manifest); - Ast_409.Parsetree.pms_attributes = (copy_attributes pms_attributes); - Ast_409.Parsetree.pms_loc = (copy_location pms_loc) - } -and copy_module_declaration : - Ast_410.Parsetree.module_declaration -> - Ast_409.Parsetree.module_declaration - = - fun - { Ast_410.Parsetree.pmd_name = pmd_name; - Ast_410.Parsetree.pmd_type = pmd_type; - Ast_410.Parsetree.pmd_attributes = pmd_attributes; - Ast_410.Parsetree.pmd_loc = pmd_loc } - -> - { - Ast_409.Parsetree.pmd_name = - (copy_loc (function - | None -> migration_error pmd_name.loc Anonymous_module_declaration - | Some x -> x) pmd_name); - Ast_409.Parsetree.pmd_type = (copy_module_type pmd_type); - Ast_409.Parsetree.pmd_attributes = (copy_attributes pmd_attributes); - Ast_409.Parsetree.pmd_loc = (copy_location pmd_loc) - } -and copy_type_exception : - Ast_410.Parsetree.type_exception -> Ast_409.Parsetree.type_exception = - fun - { Ast_410.Parsetree.ptyexn_constructor = ptyexn_constructor; - Ast_410.Parsetree.ptyexn_loc = ptyexn_loc; - Ast_410.Parsetree.ptyexn_attributes = ptyexn_attributes } - -> - { - Ast_409.Parsetree.ptyexn_constructor = - (copy_extension_constructor ptyexn_constructor); - Ast_409.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); - Ast_409.Parsetree.ptyexn_attributes = - (copy_attributes ptyexn_attributes) - } -and copy_type_extension : - Ast_410.Parsetree.type_extension -> Ast_409.Parsetree.type_extension = - fun - { Ast_410.Parsetree.ptyext_path = ptyext_path; - Ast_410.Parsetree.ptyext_params = ptyext_params; - Ast_410.Parsetree.ptyext_constructors = ptyext_constructors; - Ast_410.Parsetree.ptyext_private = ptyext_private; - Ast_410.Parsetree.ptyext_loc = ptyext_loc; - Ast_410.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - Ast_409.Parsetree.ptyext_path = (copy_loc copy_Longident_t ptyext_path); - Ast_409.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - ptyext_params); - Ast_409.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor ptyext_constructors); - Ast_409.Parsetree.ptyext_private = (copy_private_flag ptyext_private); - Ast_409.Parsetree.ptyext_loc = (copy_location ptyext_loc); - Ast_409.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } -and copy_extension_constructor : - Ast_410.Parsetree.extension_constructor -> - Ast_409.Parsetree.extension_constructor - = - fun - { Ast_410.Parsetree.pext_name = pext_name; - Ast_410.Parsetree.pext_kind = pext_kind; - Ast_410.Parsetree.pext_loc = pext_loc; - Ast_410.Parsetree.pext_attributes = pext_attributes } - -> - { - Ast_409.Parsetree.pext_name = (copy_loc (fun x -> x) pext_name); - Ast_409.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - Ast_409.Parsetree.pext_loc = (copy_location pext_loc); - Ast_409.Parsetree.pext_attributes = (copy_attributes pext_attributes) - } -and copy_extension_constructor_kind : - Ast_410.Parsetree.extension_constructor_kind -> - Ast_409.Parsetree.extension_constructor_kind - = - function - | Ast_410.Parsetree.Pext_decl (x0, x1) -> - Ast_409.Parsetree.Pext_decl - ((copy_constructor_arguments x0), (map_option copy_core_type x1)) - | Ast_410.Parsetree.Pext_rebind x0 -> - Ast_409.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) -and copy_type_declaration : - Ast_410.Parsetree.type_declaration -> Ast_409.Parsetree.type_declaration = - fun - { Ast_410.Parsetree.ptype_name = ptype_name; - Ast_410.Parsetree.ptype_params = ptype_params; - Ast_410.Parsetree.ptype_cstrs = ptype_cstrs; - Ast_410.Parsetree.ptype_kind = ptype_kind; - Ast_410.Parsetree.ptype_private = ptype_private; - Ast_410.Parsetree.ptype_manifest = ptype_manifest; - Ast_410.Parsetree.ptype_attributes = ptype_attributes; - Ast_410.Parsetree.ptype_loc = ptype_loc } - -> - { - Ast_409.Parsetree.ptype_name = (copy_loc (fun x -> x) ptype_name); - Ast_409.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - ptype_params); - Ast_409.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0, x1, x2) = x in - ((copy_core_type x0), (copy_core_type x1), (copy_location x2))) - ptype_cstrs); - Ast_409.Parsetree.ptype_kind = (copy_type_kind ptype_kind); - Ast_409.Parsetree.ptype_private = (copy_private_flag ptype_private); - Ast_409.Parsetree.ptype_manifest = - (map_option copy_core_type ptype_manifest); - Ast_409.Parsetree.ptype_attributes = (copy_attributes ptype_attributes); - Ast_409.Parsetree.ptype_loc = (copy_location ptype_loc) - } -and copy_private_flag : - Ast_410.Asttypes.private_flag -> Ast_409.Asttypes.private_flag = - function - | Ast_410.Asttypes.Private -> Ast_409.Asttypes.Private - | Ast_410.Asttypes.Public -> Ast_409.Asttypes.Public -and copy_type_kind : - Ast_410.Parsetree.type_kind -> Ast_409.Parsetree.type_kind = - function - | Ast_410.Parsetree.Ptype_abstract -> Ast_409.Parsetree.Ptype_abstract - | Ast_410.Parsetree.Ptype_variant x0 -> - Ast_409.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | Ast_410.Parsetree.Ptype_record x0 -> - Ast_409.Parsetree.Ptype_record (List.map copy_label_declaration x0) - | Ast_410.Parsetree.Ptype_open -> Ast_409.Parsetree.Ptype_open -and copy_constructor_declaration : - Ast_410.Parsetree.constructor_declaration -> - Ast_409.Parsetree.constructor_declaration - = - fun - { Ast_410.Parsetree.pcd_name = pcd_name; - Ast_410.Parsetree.pcd_args = pcd_args; - Ast_410.Parsetree.pcd_res = pcd_res; - Ast_410.Parsetree.pcd_loc = pcd_loc; - Ast_410.Parsetree.pcd_attributes = pcd_attributes } - -> - { - Ast_409.Parsetree.pcd_name = (copy_loc (fun x -> x) pcd_name); - Ast_409.Parsetree.pcd_args = (copy_constructor_arguments pcd_args); - Ast_409.Parsetree.pcd_res = (map_option copy_core_type pcd_res); - Ast_409.Parsetree.pcd_loc = (copy_location pcd_loc); - Ast_409.Parsetree.pcd_attributes = (copy_attributes pcd_attributes) - } -and copy_constructor_arguments : - Ast_410.Parsetree.constructor_arguments -> - Ast_409.Parsetree.constructor_arguments - = - function - | Ast_410.Parsetree.Pcstr_tuple x0 -> - Ast_409.Parsetree.Pcstr_tuple (List.map copy_core_type x0) - | Ast_410.Parsetree.Pcstr_record x0 -> - Ast_409.Parsetree.Pcstr_record (List.map copy_label_declaration x0) -and copy_label_declaration : - Ast_410.Parsetree.label_declaration -> Ast_409.Parsetree.label_declaration - = - fun - { Ast_410.Parsetree.pld_name = pld_name; - Ast_410.Parsetree.pld_mutable = pld_mutable; - Ast_410.Parsetree.pld_type = pld_type; - Ast_410.Parsetree.pld_loc = pld_loc; - Ast_410.Parsetree.pld_attributes = pld_attributes } - -> - { - Ast_409.Parsetree.pld_name = (copy_loc (fun x -> x) pld_name); - Ast_409.Parsetree.pld_mutable = (copy_mutable_flag pld_mutable); - Ast_409.Parsetree.pld_type = (copy_core_type pld_type); - Ast_409.Parsetree.pld_loc = (copy_location pld_loc); - Ast_409.Parsetree.pld_attributes = (copy_attributes pld_attributes) - } -and copy_mutable_flag : - Ast_410.Asttypes.mutable_flag -> Ast_409.Asttypes.mutable_flag = - function - | Ast_410.Asttypes.Immutable -> Ast_409.Asttypes.Immutable - | Ast_410.Asttypes.Mutable -> Ast_409.Asttypes.Mutable -and copy_variance : Ast_410.Asttypes.variance -> Ast_409.Asttypes.variance = - function - | Ast_410.Asttypes.Covariant -> Ast_409.Asttypes.Covariant - | Ast_410.Asttypes.Contravariant -> Ast_409.Asttypes.Contravariant - | Ast_410.Asttypes.Invariant -> Ast_409.Asttypes.Invariant -and copy_value_description : - Ast_410.Parsetree.value_description -> Ast_409.Parsetree.value_description - = - fun - { Ast_410.Parsetree.pval_name = pval_name; - Ast_410.Parsetree.pval_type = pval_type; - Ast_410.Parsetree.pval_prim = pval_prim; - Ast_410.Parsetree.pval_attributes = pval_attributes; - Ast_410.Parsetree.pval_loc = pval_loc } - -> - { - Ast_409.Parsetree.pval_name = (copy_loc (fun x -> x) pval_name); - Ast_409.Parsetree.pval_type = (copy_core_type pval_type); - Ast_409.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - Ast_409.Parsetree.pval_attributes = (copy_attributes pval_attributes); - Ast_409.Parsetree.pval_loc = (copy_location pval_loc) - } -and copy_object_field_desc : - Ast_410.Parsetree.object_field_desc -> Ast_409.Parsetree.object_field_desc - = - function - | Ast_410.Parsetree.Otag (x0, x1) -> - Ast_409.Parsetree.Otag ((copy_loc copy_label x0), (copy_core_type x1)) - | Ast_410.Parsetree.Oinherit x0 -> - Ast_409.Parsetree.Oinherit (copy_core_type x0) -and copy_arg_label : Ast_410.Asttypes.arg_label -> Ast_409.Asttypes.arg_label - = - function - | Ast_410.Asttypes.Nolabel -> Ast_409.Asttypes.Nolabel - | Ast_410.Asttypes.Labelled x0 -> Ast_409.Asttypes.Labelled x0 - | Ast_410.Asttypes.Optional x0 -> Ast_409.Asttypes.Optional x0 -and copy_closed_flag : - Ast_410.Asttypes.closed_flag -> Ast_409.Asttypes.closed_flag = - function - | Ast_410.Asttypes.Closed -> Ast_409.Asttypes.Closed - | Ast_410.Asttypes.Open -> Ast_409.Asttypes.Open -and copy_label : Ast_410.Asttypes.label -> Ast_409.Asttypes.label = - fun x -> x -and copy_rec_flag : Ast_410.Asttypes.rec_flag -> Ast_409.Asttypes.rec_flag = - function - | Ast_410.Asttypes.Nonrecursive -> Ast_409.Asttypes.Nonrecursive - | Ast_410.Asttypes.Recursive -> Ast_409.Asttypes.Recursive -and copy_constant : Ast_410.Parsetree.constant -> Ast_409.Parsetree.constant - = - function - | Ast_410.Parsetree.Pconst_integer (x0, x1) -> - Ast_409.Parsetree.Pconst_integer (x0, (map_option (fun x -> x) x1)) - | Ast_410.Parsetree.Pconst_char x0 -> Ast_409.Parsetree.Pconst_char x0 - | Ast_410.Parsetree.Pconst_string (x0, x1) -> - Ast_409.Parsetree.Pconst_string (x0, (map_option (fun x -> x) x1)) - | Ast_410.Parsetree.Pconst_float (x0, x1) -> - Ast_409.Parsetree.Pconst_float (x0, (map_option (fun x -> x) x1)) -and copy_Longident_t : Ast_410.Longident.t -> Ast_409.Longident.t = - function - | Ast_410.Longident.Lident x0 -> Ast_409.Longident.Lident x0 - | Ast_410.Longident.Ldot (x0, x1) -> - Ast_409.Longident.Ldot ((copy_Longident_t x0), x1) - | Ast_410.Longident.Lapply (x0, x1) -> - Ast_409.Longident.Lapply ((copy_Longident_t x0), (copy_Longident_t x1)) -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 Ast_410.Asttypes.loc -> 'g0 Ast_409.Asttypes.loc - = - fun f0 -> - fun { Ast_410.Asttypes.txt = txt; Ast_410.Asttypes.loc = loc } -> - { - Ast_409.Asttypes.txt = (f0 txt); - Ast_409.Asttypes.loc = (copy_location loc) - } -and copy_location : Ast_410.Location.t -> Ast_409.Location.t = - fun - { Ast_410.Location.loc_start = loc_start; - Ast_410.Location.loc_end = loc_end; - Ast_410.Location.loc_ghost = loc_ghost } - -> - { - Ast_409.Location.loc_start = (copy_position loc_start); - Ast_409.Location.loc_end = (copy_position loc_end); - Ast_409.Location.loc_ghost = loc_ghost - } -and copy_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum - } -let copy_expr = copy_expression -let copy_pat = copy_pattern -let copy_typ = copy_core_type diff --git a/src/vendored-omp/src/migrate_parsetree_410_411.ml b/src/vendored-omp/src/migrate_parsetree_410_411.ml index 2c8775243..54611d7ac 100644 --- a/src/vendored-omp/src/migrate_parsetree_410_411.ml +++ b/src/vendored-omp/src/migrate_parsetree_410_411.ml @@ -14,128 +14,3 @@ (**************************************************************************) include Migrate_parsetree_410_411_migrate - -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload"; - "binding_op"; "module_substitution"; "open_declaration"; "type_exception" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - binding_op; - module_substitution; - open_declaration; - type_exception; - (*$*) - } as mapper) -> - let module Def = Migrate_parsetree_def in - let module R = Migrate_parsetree_411_410_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - binding_op = (fun _ x -> copy_binding_op (binding_op mapper (R.copy_binding_op x))); - module_substitution = (fun _ x -> copy_module_substitution (module_substitution mapper (R.copy_module_substitution x))); - open_declaration = (fun _ x -> copy_open_declaration (open_declaration mapper (R.copy_open_declaration x))); - type_exception = (fun _ x -> copy_type_exception (type_exception mapper (R.copy_type_exception x))); - (*$*) - constant = (fun _ x -> x) - } diff --git a/src/vendored-omp/src/migrate_parsetree_410_411_migrate.ml b/src/vendored-omp/src/migrate_parsetree_410_411_migrate.ml index c807845bf..4743e2323 100644 --- a/src/vendored-omp/src/migrate_parsetree_410_411_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_410_411_migrate.ml @@ -165,6 +165,11 @@ and copy_out_extension_constructor : (Option.map copy_out_type oext_ret_type); Ast_411.Outcometree.oext_private = (copy_private_flag oext_private) } +and copy_private_flag : + Ast_410.Asttypes.private_flag -> Ast_411.Asttypes.private_flag = + function + | Ast_410.Asttypes.Private -> Ast_411.Asttypes.Private + | Ast_410.Asttypes.Public -> Ast_411.Asttypes.Public and copy_out_rec_status : Ast_410.Outcometree.out_rec_status -> Ast_411.Outcometree.out_rec_status = function @@ -316,1207 +321,3 @@ and copy_out_name : Ast_410.Outcometree.out_name -> Ast_411.Outcometree.out_name = fun { Ast_410.Outcometree.printed_name = printed_name } -> { Ast_411.Outcometree.printed_name = printed_name } -and copy_toplevel_phrase : - Ast_410.Parsetree.toplevel_phrase -> Ast_411.Parsetree.toplevel_phrase = - function - | Ast_410.Parsetree.Ptop_def x0 -> - Ast_411.Parsetree.Ptop_def (copy_structure x0) - | Ast_410.Parsetree.Ptop_dir x0 -> - Ast_411.Parsetree.Ptop_dir (copy_toplevel_directive x0) -and copy_toplevel_directive : - Ast_410.Parsetree.toplevel_directive -> - Ast_411.Parsetree.toplevel_directive - = - fun - { Ast_410.Parsetree.pdir_name = pdir_name; - Ast_410.Parsetree.pdir_arg = pdir_arg; - Ast_410.Parsetree.pdir_loc = pdir_loc } - -> - { - Ast_411.Parsetree.pdir_name = (copy_loc (fun x -> x) pdir_name); - Ast_411.Parsetree.pdir_arg = - (Option.map copy_directive_argument pdir_arg); - Ast_411.Parsetree.pdir_loc = (copy_location pdir_loc) - } -and copy_directive_argument : - Ast_410.Parsetree.directive_argument -> - Ast_411.Parsetree.directive_argument - = - fun - { Ast_410.Parsetree.pdira_desc = pdira_desc; - Ast_410.Parsetree.pdira_loc = pdira_loc } - -> - { - Ast_411.Parsetree.pdira_desc = - (copy_directive_argument_desc pdira_desc); - Ast_411.Parsetree.pdira_loc = (copy_location pdira_loc) - } -and copy_directive_argument_desc : - Ast_410.Parsetree.directive_argument_desc -> - Ast_411.Parsetree.directive_argument_desc - = - function - | Ast_410.Parsetree.Pdir_string x0 -> Ast_411.Parsetree.Pdir_string x0 - | Ast_410.Parsetree.Pdir_int (x0, x1) -> - Ast_411.Parsetree.Pdir_int (x0, (Option.map (fun x -> x) x1)) - | Ast_410.Parsetree.Pdir_ident x0 -> - Ast_411.Parsetree.Pdir_ident (copy_Longident_t x0) - | Ast_410.Parsetree.Pdir_bool x0 -> Ast_411.Parsetree.Pdir_bool x0 -and copy_expression : - Ast_410.Parsetree.expression -> Ast_411.Parsetree.expression = - fun - { Ast_410.Parsetree.pexp_desc = pexp_desc; - Ast_410.Parsetree.pexp_loc = pexp_loc; - Ast_410.Parsetree.pexp_loc_stack = pexp_loc_stack; - Ast_410.Parsetree.pexp_attributes = pexp_attributes } - -> - { - Ast_411.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - Ast_411.Parsetree.pexp_loc = (copy_location pexp_loc); - Ast_411.Parsetree.pexp_loc_stack = (copy_location_stack pexp_loc_stack); - Ast_411.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } -and copy_expr x = copy_expression x -and copy_expression_desc : - Ast_410.Parsetree.expression_desc -> Ast_411.Parsetree.expression_desc = - function - | Ast_410.Parsetree.Pexp_ident x0 -> - Ast_411.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) - | Ast_410.Parsetree.Pexp_constant x0 -> - Ast_411.Parsetree.Pexp_constant (copy_constant x0) - | Ast_410.Parsetree.Pexp_let (x0, x1, x2) -> - Ast_411.Parsetree.Pexp_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_expression x2)) - | Ast_410.Parsetree.Pexp_function x0 -> - Ast_411.Parsetree.Pexp_function (List.map copy_case x0) - | Ast_410.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_411.Parsetree.Pexp_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_expression x3)) - | Ast_410.Parsetree.Pexp_apply (x0, x1) -> - Ast_411.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_410.Parsetree.Pexp_match (x0, x1) -> - Ast_411.Parsetree.Pexp_match - ((copy_expression x0), (List.map copy_case x1)) - | Ast_410.Parsetree.Pexp_try (x0, x1) -> - Ast_411.Parsetree.Pexp_try - ((copy_expression x0), (List.map copy_case x1)) - | Ast_410.Parsetree.Pexp_tuple x0 -> - Ast_411.Parsetree.Pexp_tuple (List.map copy_expression x0) - | Ast_410.Parsetree.Pexp_construct (x0, x1) -> - Ast_411.Parsetree.Pexp_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_expression x1)) - | Ast_410.Parsetree.Pexp_variant (x0, x1) -> - Ast_411.Parsetree.Pexp_variant - ((copy_label x0), (Option.map copy_expression x1)) - | Ast_410.Parsetree.Pexp_record (x0, x1) -> - Ast_411.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_expression x1))) x0), - (Option.map copy_expression x1)) - | Ast_410.Parsetree.Pexp_field (x0, x1) -> - Ast_411.Parsetree.Pexp_field - ((copy_expression x0), (copy_loc copy_Longident_t x1)) - | Ast_410.Parsetree.Pexp_setfield (x0, x1, x2) -> - Ast_411.Parsetree.Pexp_setfield - ((copy_expression x0), (copy_loc copy_Longident_t x1), - (copy_expression x2)) - | Ast_410.Parsetree.Pexp_array x0 -> - Ast_411.Parsetree.Pexp_array (List.map copy_expression x0) - | Ast_410.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> - Ast_411.Parsetree.Pexp_ifthenelse - ((copy_expression x0), (copy_expression x1), - (Option.map copy_expression x2)) - | Ast_410.Parsetree.Pexp_sequence (x0, x1) -> - Ast_411.Parsetree.Pexp_sequence - ((copy_expression x0), (copy_expression x1)) - | Ast_410.Parsetree.Pexp_while (x0, x1) -> - Ast_411.Parsetree.Pexp_while - ((copy_expression x0), (copy_expression x1)) - | Ast_410.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> - Ast_411.Parsetree.Pexp_for - ((copy_pattern x0), (copy_expression x1), (copy_expression x2), - (copy_direction_flag x3), (copy_expression x4)) - | Ast_410.Parsetree.Pexp_constraint (x0, x1) -> - Ast_411.Parsetree.Pexp_constraint - ((copy_expression x0), (copy_core_type x1)) - | Ast_410.Parsetree.Pexp_coerce (x0, x1, x2) -> - Ast_411.Parsetree.Pexp_coerce - ((copy_expression x0), (Option.map copy_core_type x1), - (copy_core_type x2)) - | Ast_410.Parsetree.Pexp_send (x0, x1) -> - Ast_411.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc copy_label x1)) - | Ast_410.Parsetree.Pexp_new x0 -> - Ast_411.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) - | Ast_410.Parsetree.Pexp_setinstvar (x0, x1) -> - Ast_411.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), (copy_expression x1)) - | Ast_410.Parsetree.Pexp_override x0 -> - Ast_411.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_label x0), (copy_expression x1))) x0) - | Ast_410.Parsetree.Pexp_letmodule (x0, x1, x2) -> - Ast_411.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_expr x1), (copy_expression x2)) - | Ast_410.Parsetree.Pexp_letexception (x0, x1) -> - Ast_411.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), (copy_expression x1)) - | Ast_410.Parsetree.Pexp_assert x0 -> - Ast_411.Parsetree.Pexp_assert (copy_expression x0) - | Ast_410.Parsetree.Pexp_lazy x0 -> - Ast_411.Parsetree.Pexp_lazy (copy_expression x0) - | Ast_410.Parsetree.Pexp_poly (x0, x1) -> - Ast_411.Parsetree.Pexp_poly - ((copy_expression x0), (Option.map copy_core_type x1)) - | Ast_410.Parsetree.Pexp_object x0 -> - Ast_411.Parsetree.Pexp_object (copy_class_structure x0) - | Ast_410.Parsetree.Pexp_newtype (x0, x1) -> - Ast_411.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | Ast_410.Parsetree.Pexp_pack x0 -> - Ast_411.Parsetree.Pexp_pack (copy_module_expr x0) - | Ast_410.Parsetree.Pexp_open (x0, x1) -> - Ast_411.Parsetree.Pexp_open - ((copy_open_declaration x0), (copy_expression x1)) - | Ast_410.Parsetree.Pexp_letop x0 -> - Ast_411.Parsetree.Pexp_letop (copy_letop x0) - | Ast_410.Parsetree.Pexp_extension x0 -> - Ast_411.Parsetree.Pexp_extension (copy_extension x0) - | Ast_410.Parsetree.Pexp_unreachable -> Ast_411.Parsetree.Pexp_unreachable -and copy_letop : Ast_410.Parsetree.letop -> Ast_411.Parsetree.letop = - fun - { Ast_410.Parsetree.let_ = let_; Ast_410.Parsetree.ands = ands; - Ast_410.Parsetree.body = body } - -> - { - Ast_411.Parsetree.let_ = (copy_binding_op let_); - Ast_411.Parsetree.ands = (List.map copy_binding_op ands); - Ast_411.Parsetree.body = (copy_expression body) - } -and copy_binding_op : - Ast_410.Parsetree.binding_op -> Ast_411.Parsetree.binding_op = - fun - { Ast_410.Parsetree.pbop_op = pbop_op; - Ast_410.Parsetree.pbop_pat = pbop_pat; - Ast_410.Parsetree.pbop_exp = pbop_exp; - Ast_410.Parsetree.pbop_loc = pbop_loc } - -> - { - Ast_411.Parsetree.pbop_op = (copy_loc (fun x -> x) pbop_op); - Ast_411.Parsetree.pbop_pat = (copy_pattern pbop_pat); - Ast_411.Parsetree.pbop_exp = (copy_expression pbop_exp); - Ast_411.Parsetree.pbop_loc = (copy_location pbop_loc) - } -and copy_direction_flag : - Ast_410.Asttypes.direction_flag -> Ast_411.Asttypes.direction_flag = - function - | Ast_410.Asttypes.Upto -> Ast_411.Asttypes.Upto - | Ast_410.Asttypes.Downto -> Ast_411.Asttypes.Downto -and copy_case : Ast_410.Parsetree.case -> Ast_411.Parsetree.case = - fun - { Ast_410.Parsetree.pc_lhs = pc_lhs; - Ast_410.Parsetree.pc_guard = pc_guard; - Ast_410.Parsetree.pc_rhs = pc_rhs } - -> - { - Ast_411.Parsetree.pc_lhs = (copy_pattern pc_lhs); - Ast_411.Parsetree.pc_guard = (Option.map copy_expression pc_guard); - Ast_411.Parsetree.pc_rhs = (copy_expression pc_rhs) - } -and copy_cases : Ast_410.Parsetree.case list -> Ast_411.Parsetree.case list = - fun x -> List.map copy_case x -and copy_value_binding : - Ast_410.Parsetree.value_binding -> Ast_411.Parsetree.value_binding = - fun - { Ast_410.Parsetree.pvb_pat = pvb_pat; - Ast_410.Parsetree.pvb_expr = pvb_expr; - Ast_410.Parsetree.pvb_attributes = pvb_attributes; - Ast_410.Parsetree.pvb_loc = pvb_loc } - -> - { - Ast_411.Parsetree.pvb_pat = (copy_pattern pvb_pat); - Ast_411.Parsetree.pvb_expr = (copy_expression pvb_expr); - Ast_411.Parsetree.pvb_attributes = (copy_attributes pvb_attributes); - Ast_411.Parsetree.pvb_loc = (copy_location pvb_loc) - } -and copy_pattern : Ast_410.Parsetree.pattern -> Ast_411.Parsetree.pattern = - fun - { Ast_410.Parsetree.ppat_desc = ppat_desc; - Ast_410.Parsetree.ppat_loc = ppat_loc; - Ast_410.Parsetree.ppat_loc_stack = ppat_loc_stack; - Ast_410.Parsetree.ppat_attributes = ppat_attributes } - -> - { - Ast_411.Parsetree.ppat_desc = (copy_pattern_desc ppat_desc); - Ast_411.Parsetree.ppat_loc = (copy_location ppat_loc); - Ast_411.Parsetree.ppat_loc_stack = (copy_location_stack ppat_loc_stack); - Ast_411.Parsetree.ppat_attributes = (copy_attributes ppat_attributes) - } -and copy_pat x = copy_pattern x -and copy_pattern_desc : - Ast_410.Parsetree.pattern_desc -> Ast_411.Parsetree.pattern_desc = - function - | Ast_410.Parsetree.Ppat_any -> Ast_411.Parsetree.Ppat_any - | Ast_410.Parsetree.Ppat_var x0 -> - Ast_411.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | Ast_410.Parsetree.Ppat_alias (x0, x1) -> - Ast_411.Parsetree.Ppat_alias - ((copy_pattern x0), (copy_loc (fun x -> x) x1)) - | Ast_410.Parsetree.Ppat_constant x0 -> - Ast_411.Parsetree.Ppat_constant (copy_constant x0) - | Ast_410.Parsetree.Ppat_interval (x0, x1) -> - Ast_411.Parsetree.Ppat_interval - ((copy_constant x0), (copy_constant x1)) - | Ast_410.Parsetree.Ppat_tuple x0 -> - Ast_411.Parsetree.Ppat_tuple (List.map copy_pattern x0) - | Ast_410.Parsetree.Ppat_construct (x0, x1) -> - Ast_411.Parsetree.Ppat_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_pattern x1)) - | Ast_410.Parsetree.Ppat_variant (x0, x1) -> - Ast_411.Parsetree.Ppat_variant - ((copy_label x0), (Option.map copy_pattern x1)) - | Ast_410.Parsetree.Ppat_record (x0, x1) -> - Ast_411.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | Ast_410.Parsetree.Ppat_array x0 -> - Ast_411.Parsetree.Ppat_array (List.map copy_pattern x0) - | Ast_410.Parsetree.Ppat_or (x0, x1) -> - Ast_411.Parsetree.Ppat_or ((copy_pattern x0), (copy_pattern x1)) - | Ast_410.Parsetree.Ppat_constraint (x0, x1) -> - Ast_411.Parsetree.Ppat_constraint - ((copy_pattern x0), (copy_core_type x1)) - | Ast_410.Parsetree.Ppat_type x0 -> - Ast_411.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) - | Ast_410.Parsetree.Ppat_lazy x0 -> - Ast_411.Parsetree.Ppat_lazy (copy_pattern x0) - | Ast_410.Parsetree.Ppat_unpack x0 -> - Ast_411.Parsetree.Ppat_unpack - (copy_loc (fun x -> Option.map (fun x -> x) x) x0) - | Ast_410.Parsetree.Ppat_exception x0 -> - Ast_411.Parsetree.Ppat_exception (copy_pattern x0) - | Ast_410.Parsetree.Ppat_extension x0 -> - Ast_411.Parsetree.Ppat_extension (copy_extension x0) - | Ast_410.Parsetree.Ppat_open (x0, x1) -> - Ast_411.Parsetree.Ppat_open - ((copy_loc copy_Longident_t x0), (copy_pattern x1)) -and copy_core_type : - Ast_410.Parsetree.core_type -> Ast_411.Parsetree.core_type = - fun - { Ast_410.Parsetree.ptyp_desc = ptyp_desc; - Ast_410.Parsetree.ptyp_loc = ptyp_loc; - Ast_410.Parsetree.ptyp_loc_stack = ptyp_loc_stack; - Ast_410.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - Ast_411.Parsetree.ptyp_desc = (copy_core_type_desc ptyp_desc); - Ast_411.Parsetree.ptyp_loc = (copy_location ptyp_loc); - Ast_411.Parsetree.ptyp_loc_stack = (copy_location_stack ptyp_loc_stack); - Ast_411.Parsetree.ptyp_attributes = (copy_attributes ptyp_attributes) - } -and copy_typ x = copy_core_type x -and copy_location_stack : - Ast_410.Parsetree.location_stack -> Ast_411.Parsetree.location_stack = - fun x -> List.map copy_location x -and copy_core_type_desc : - Ast_410.Parsetree.core_type_desc -> Ast_411.Parsetree.core_type_desc = - function - | Ast_410.Parsetree.Ptyp_any -> Ast_411.Parsetree.Ptyp_any - | Ast_410.Parsetree.Ptyp_var x0 -> Ast_411.Parsetree.Ptyp_var x0 - | Ast_410.Parsetree.Ptyp_arrow (x0, x1, x2) -> - Ast_411.Parsetree.Ptyp_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_core_type x2)) - | Ast_410.Parsetree.Ptyp_tuple x0 -> - Ast_411.Parsetree.Ptyp_tuple (List.map copy_core_type x0) - | Ast_410.Parsetree.Ptyp_constr (x0, x1) -> - Ast_411.Parsetree.Ptyp_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_410.Parsetree.Ptyp_object (x0, x1) -> - Ast_411.Parsetree.Ptyp_object - ((List.map copy_object_field x0), (copy_closed_flag x1)) - | Ast_410.Parsetree.Ptyp_class (x0, x1) -> - Ast_411.Parsetree.Ptyp_class - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_410.Parsetree.Ptyp_alias (x0, x1) -> - Ast_411.Parsetree.Ptyp_alias ((copy_core_type x0), x1) - | Ast_410.Parsetree.Ptyp_variant (x0, x1, x2) -> - Ast_411.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), (copy_closed_flag x1), - (Option.map (fun x -> List.map copy_label x) x2)) - | Ast_410.Parsetree.Ptyp_poly (x0, x1) -> - Ast_411.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | Ast_410.Parsetree.Ptyp_package x0 -> - Ast_411.Parsetree.Ptyp_package (copy_package_type x0) - | Ast_410.Parsetree.Ptyp_extension x0 -> - Ast_411.Parsetree.Ptyp_extension (copy_extension x0) -and copy_package_type : - Ast_410.Parsetree.package_type -> Ast_411.Parsetree.package_type = - fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_core_type x1))) x1)) -and copy_row_field : - Ast_410.Parsetree.row_field -> Ast_411.Parsetree.row_field = - fun - { Ast_410.Parsetree.prf_desc = prf_desc; - Ast_410.Parsetree.prf_loc = prf_loc; - Ast_410.Parsetree.prf_attributes = prf_attributes } - -> - { - Ast_411.Parsetree.prf_desc = (copy_row_field_desc prf_desc); - Ast_411.Parsetree.prf_loc = (copy_location prf_loc); - Ast_411.Parsetree.prf_attributes = (copy_attributes prf_attributes) - } -and copy_row_field_desc : - Ast_410.Parsetree.row_field_desc -> Ast_411.Parsetree.row_field_desc = - function - | Ast_410.Parsetree.Rtag (x0, x1, x2) -> - Ast_411.Parsetree.Rtag - ((copy_loc copy_label x0), x1, (List.map copy_core_type x2)) - | Ast_410.Parsetree.Rinherit x0 -> - Ast_411.Parsetree.Rinherit (copy_core_type x0) -and copy_object_field : - Ast_410.Parsetree.object_field -> Ast_411.Parsetree.object_field = - fun - { Ast_410.Parsetree.pof_desc = pof_desc; - Ast_410.Parsetree.pof_loc = pof_loc; - Ast_410.Parsetree.pof_attributes = pof_attributes } - -> - { - Ast_411.Parsetree.pof_desc = (copy_object_field_desc pof_desc); - Ast_411.Parsetree.pof_loc = (copy_location pof_loc); - Ast_411.Parsetree.pof_attributes = (copy_attributes pof_attributes) - } -and copy_attributes : - Ast_410.Parsetree.attributes -> Ast_411.Parsetree.attributes = - fun x -> List.map copy_attribute x -and copy_attribute : - Ast_410.Parsetree.attribute -> Ast_411.Parsetree.attribute = - fun - { Ast_410.Parsetree.attr_name = attr_name; - Ast_410.Parsetree.attr_payload = attr_payload; - Ast_410.Parsetree.attr_loc = attr_loc } - -> - { - Ast_411.Parsetree.attr_name = (copy_loc (fun x -> x) attr_name); - Ast_411.Parsetree.attr_payload = (copy_payload attr_payload); - Ast_411.Parsetree.attr_loc = (copy_location attr_loc) - } -and copy_payload : Ast_410.Parsetree.payload -> Ast_411.Parsetree.payload = - function - | Ast_410.Parsetree.PStr x0 -> Ast_411.Parsetree.PStr (copy_structure x0) - | Ast_410.Parsetree.PSig x0 -> Ast_411.Parsetree.PSig (copy_signature x0) - | Ast_410.Parsetree.PTyp x0 -> Ast_411.Parsetree.PTyp (copy_core_type x0) - | Ast_410.Parsetree.PPat (x0, x1) -> - Ast_411.Parsetree.PPat - ((copy_pattern x0), (Option.map copy_expression x1)) -and copy_structure : - Ast_410.Parsetree.structure -> Ast_411.Parsetree.structure = - fun x -> List.map copy_structure_item x -and copy_structure_item : - Ast_410.Parsetree.structure_item -> Ast_411.Parsetree.structure_item = - fun - { Ast_410.Parsetree.pstr_desc = pstr_desc; - Ast_410.Parsetree.pstr_loc = pstr_loc } - -> - { - Ast_411.Parsetree.pstr_desc = (copy_structure_item_desc pstr_desc); - Ast_411.Parsetree.pstr_loc = (copy_location pstr_loc) - } -and copy_structure_item_desc : - Ast_410.Parsetree.structure_item_desc -> - Ast_411.Parsetree.structure_item_desc - = - function - | Ast_410.Parsetree.Pstr_eval (x0, x1) -> - Ast_411.Parsetree.Pstr_eval - ((copy_expression x0), (copy_attributes x1)) - | Ast_410.Parsetree.Pstr_value (x0, x1) -> - Ast_411.Parsetree.Pstr_value - ((copy_rec_flag x0), (List.map copy_value_binding x1)) - | Ast_410.Parsetree.Pstr_primitive x0 -> - Ast_411.Parsetree.Pstr_primitive (copy_value_description x0) - | Ast_410.Parsetree.Pstr_type (x0, x1) -> - Ast_411.Parsetree.Pstr_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_410.Parsetree.Pstr_typext x0 -> - Ast_411.Parsetree.Pstr_typext (copy_type_extension x0) - | Ast_410.Parsetree.Pstr_exception x0 -> - Ast_411.Parsetree.Pstr_exception (copy_type_exception x0) - | Ast_410.Parsetree.Pstr_module x0 -> - Ast_411.Parsetree.Pstr_module (copy_module_binding x0) - | Ast_410.Parsetree.Pstr_recmodule x0 -> - Ast_411.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) - | Ast_410.Parsetree.Pstr_modtype x0 -> - Ast_411.Parsetree.Pstr_modtype (copy_module_type_declaration x0) - | Ast_410.Parsetree.Pstr_open x0 -> - Ast_411.Parsetree.Pstr_open (copy_open_declaration x0) - | Ast_410.Parsetree.Pstr_class x0 -> - Ast_411.Parsetree.Pstr_class (List.map copy_class_declaration x0) - | Ast_410.Parsetree.Pstr_class_type x0 -> - Ast_411.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | Ast_410.Parsetree.Pstr_include x0 -> - Ast_411.Parsetree.Pstr_include (copy_include_declaration x0) - | Ast_410.Parsetree.Pstr_attribute x0 -> - Ast_411.Parsetree.Pstr_attribute (copy_attribute x0) - | Ast_410.Parsetree.Pstr_extension (x0, x1) -> - Ast_411.Parsetree.Pstr_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_include_declaration : - Ast_410.Parsetree.include_declaration -> - Ast_411.Parsetree.include_declaration - = fun x -> copy_include_infos copy_module_expr x -and copy_class_declaration : - Ast_410.Parsetree.class_declaration -> Ast_411.Parsetree.class_declaration - = fun x -> copy_class_infos copy_class_expr x -and copy_class_expr : - Ast_410.Parsetree.class_expr -> Ast_411.Parsetree.class_expr = - fun - { Ast_410.Parsetree.pcl_desc = pcl_desc; - Ast_410.Parsetree.pcl_loc = pcl_loc; - Ast_410.Parsetree.pcl_attributes = pcl_attributes } - -> - { - Ast_411.Parsetree.pcl_desc = (copy_class_expr_desc pcl_desc); - Ast_411.Parsetree.pcl_loc = (copy_location pcl_loc); - Ast_411.Parsetree.pcl_attributes = (copy_attributes pcl_attributes) - } -and copy_class_expr_desc : - Ast_410.Parsetree.class_expr_desc -> Ast_411.Parsetree.class_expr_desc = - function - | Ast_410.Parsetree.Pcl_constr (x0, x1) -> - Ast_411.Parsetree.Pcl_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_410.Parsetree.Pcl_structure x0 -> - Ast_411.Parsetree.Pcl_structure (copy_class_structure x0) - | Ast_410.Parsetree.Pcl_fun (x0, x1, x2, x3) -> - Ast_411.Parsetree.Pcl_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_class_expr x3)) - | Ast_410.Parsetree.Pcl_apply (x0, x1) -> - Ast_411.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_410.Parsetree.Pcl_let (x0, x1, x2) -> - Ast_411.Parsetree.Pcl_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_class_expr x2)) - | Ast_410.Parsetree.Pcl_constraint (x0, x1) -> - Ast_411.Parsetree.Pcl_constraint - ((copy_class_expr x0), (copy_class_type x1)) - | Ast_410.Parsetree.Pcl_extension x0 -> - Ast_411.Parsetree.Pcl_extension (copy_extension x0) - | Ast_410.Parsetree.Pcl_open (x0, x1) -> - Ast_411.Parsetree.Pcl_open - ((copy_open_description x0), (copy_class_expr x1)) -and copy_class_structure : - Ast_410.Parsetree.class_structure -> Ast_411.Parsetree.class_structure = - fun - { Ast_410.Parsetree.pcstr_self = pcstr_self; - Ast_410.Parsetree.pcstr_fields = pcstr_fields } - -> - { - Ast_411.Parsetree.pcstr_self = (copy_pattern pcstr_self); - Ast_411.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } -and copy_class_field : - Ast_410.Parsetree.class_field -> Ast_411.Parsetree.class_field = - fun - { Ast_410.Parsetree.pcf_desc = pcf_desc; - Ast_410.Parsetree.pcf_loc = pcf_loc; - Ast_410.Parsetree.pcf_attributes = pcf_attributes } - -> - { - Ast_411.Parsetree.pcf_desc = (copy_class_field_desc pcf_desc); - Ast_411.Parsetree.pcf_loc = (copy_location pcf_loc); - Ast_411.Parsetree.pcf_attributes = (copy_attributes pcf_attributes) - } -and copy_class_field_desc : - Ast_410.Parsetree.class_field_desc -> Ast_411.Parsetree.class_field_desc = - function - | Ast_410.Parsetree.Pcf_inherit (x0, x1, x2) -> - Ast_411.Parsetree.Pcf_inherit - ((copy_override_flag x0), (copy_class_expr x1), - (Option.map (fun x -> copy_loc (fun x -> x) x) x2)) - | Ast_410.Parsetree.Pcf_val x0 -> - Ast_411.Parsetree.Pcf_val - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | Ast_410.Parsetree.Pcf_method x0 -> - Ast_411.Parsetree.Pcf_method - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_class_field_kind x2))) - | Ast_410.Parsetree.Pcf_constraint x0 -> - Ast_411.Parsetree.Pcf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_410.Parsetree.Pcf_initializer x0 -> - Ast_411.Parsetree.Pcf_initializer (copy_expression x0) - | Ast_410.Parsetree.Pcf_attribute x0 -> - Ast_411.Parsetree.Pcf_attribute (copy_attribute x0) - | Ast_410.Parsetree.Pcf_extension x0 -> - Ast_411.Parsetree.Pcf_extension (copy_extension x0) -and copy_class_field_kind : - Ast_410.Parsetree.class_field_kind -> Ast_411.Parsetree.class_field_kind = - function - | Ast_410.Parsetree.Cfk_virtual x0 -> - Ast_411.Parsetree.Cfk_virtual (copy_core_type x0) - | Ast_410.Parsetree.Cfk_concrete (x0, x1) -> - Ast_411.Parsetree.Cfk_concrete - ((copy_override_flag x0), (copy_expression x1)) -and copy_open_declaration : - Ast_410.Parsetree.open_declaration -> Ast_411.Parsetree.open_declaration = - fun x -> copy_open_infos copy_module_expr x -and copy_module_binding : - Ast_410.Parsetree.module_binding -> Ast_411.Parsetree.module_binding = - fun - { Ast_410.Parsetree.pmb_name = pmb_name; - Ast_410.Parsetree.pmb_expr = pmb_expr; - Ast_410.Parsetree.pmb_attributes = pmb_attributes; - Ast_410.Parsetree.pmb_loc = pmb_loc } - -> - { - Ast_411.Parsetree.pmb_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name); - Ast_411.Parsetree.pmb_expr = (copy_module_expr pmb_expr); - Ast_411.Parsetree.pmb_attributes = (copy_attributes pmb_attributes); - Ast_411.Parsetree.pmb_loc = (copy_location pmb_loc) - } -and copy_module_expr : - Ast_410.Parsetree.module_expr -> Ast_411.Parsetree.module_expr = - fun - { Ast_410.Parsetree.pmod_desc = pmod_desc; - Ast_410.Parsetree.pmod_loc = pmod_loc; - Ast_410.Parsetree.pmod_attributes = pmod_attributes } - -> - { - Ast_411.Parsetree.pmod_desc = (copy_module_expr_desc pmod_desc); - Ast_411.Parsetree.pmod_loc = (copy_location pmod_loc); - Ast_411.Parsetree.pmod_attributes = (copy_attributes pmod_attributes) - } -and copy_module_expr_desc : - Ast_410.Parsetree.module_expr_desc -> Ast_411.Parsetree.module_expr_desc = - function - | Ast_410.Parsetree.Pmod_ident x0 -> - Ast_411.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) - | Ast_410.Parsetree.Pmod_structure x0 -> - Ast_411.Parsetree.Pmod_structure (copy_structure x0) - | Ast_410.Parsetree.Pmod_functor (x0, x1) -> - Ast_411.Parsetree.Pmod_functor - ((copy_functor_parameter x0), (copy_module_expr x1)) - | Ast_410.Parsetree.Pmod_apply (x0, x1) -> - Ast_411.Parsetree.Pmod_apply - ((copy_module_expr x0), (copy_module_expr x1)) - | Ast_410.Parsetree.Pmod_constraint (x0, x1) -> - Ast_411.Parsetree.Pmod_constraint - ((copy_module_expr x0), (copy_module_type x1)) - | Ast_410.Parsetree.Pmod_unpack x0 -> - Ast_411.Parsetree.Pmod_unpack (copy_expression x0) - | Ast_410.Parsetree.Pmod_extension x0 -> - Ast_411.Parsetree.Pmod_extension (copy_extension x0) -and copy_functor_parameter : - Ast_410.Parsetree.functor_parameter -> Ast_411.Parsetree.functor_parameter - = - function - | Ast_410.Parsetree.Unit -> Ast_411.Parsetree.Unit - | Ast_410.Parsetree.Named (x0, x1) -> - Ast_411.Parsetree.Named - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_type x1)) -and copy_module_type : - Ast_410.Parsetree.module_type -> Ast_411.Parsetree.module_type = - fun - { Ast_410.Parsetree.pmty_desc = pmty_desc; - Ast_410.Parsetree.pmty_loc = pmty_loc; - Ast_410.Parsetree.pmty_attributes = pmty_attributes } - -> - { - Ast_411.Parsetree.pmty_desc = (copy_module_type_desc pmty_desc); - Ast_411.Parsetree.pmty_loc = (copy_location pmty_loc); - Ast_411.Parsetree.pmty_attributes = (copy_attributes pmty_attributes) - } -and copy_module_type_desc : - Ast_410.Parsetree.module_type_desc -> Ast_411.Parsetree.module_type_desc = - function - | Ast_410.Parsetree.Pmty_ident x0 -> - Ast_411.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) - | Ast_410.Parsetree.Pmty_signature x0 -> - Ast_411.Parsetree.Pmty_signature (copy_signature x0) - | Ast_410.Parsetree.Pmty_functor (x0, x1) -> - Ast_411.Parsetree.Pmty_functor - ((copy_functor_parameter x0), (copy_module_type x1)) - | Ast_410.Parsetree.Pmty_with (x0, x1) -> - Ast_411.Parsetree.Pmty_with - ((copy_module_type x0), (List.map copy_with_constraint x1)) - | Ast_410.Parsetree.Pmty_typeof x0 -> - Ast_411.Parsetree.Pmty_typeof (copy_module_expr x0) - | Ast_410.Parsetree.Pmty_extension x0 -> - Ast_411.Parsetree.Pmty_extension (copy_extension x0) - | Ast_410.Parsetree.Pmty_alias x0 -> - Ast_411.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) -and copy_with_constraint : - Ast_410.Parsetree.with_constraint -> Ast_411.Parsetree.with_constraint = - function - | Ast_410.Parsetree.Pwith_type (x0, x1) -> - Ast_411.Parsetree.Pwith_type - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_410.Parsetree.Pwith_module (x0, x1) -> - Ast_411.Parsetree.Pwith_module - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) - | Ast_410.Parsetree.Pwith_typesubst (x0, x1) -> - Ast_411.Parsetree.Pwith_typesubst - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_410.Parsetree.Pwith_modsubst (x0, x1) -> - Ast_411.Parsetree.Pwith_modsubst - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) -and copy_signature : - Ast_410.Parsetree.signature -> Ast_411.Parsetree.signature = - fun x -> List.map copy_signature_item x -and copy_signature_item : - Ast_410.Parsetree.signature_item -> Ast_411.Parsetree.signature_item = - fun - { Ast_410.Parsetree.psig_desc = psig_desc; - Ast_410.Parsetree.psig_loc = psig_loc } - -> - { - Ast_411.Parsetree.psig_desc = (copy_signature_item_desc psig_desc); - Ast_411.Parsetree.psig_loc = (copy_location psig_loc) - } -and copy_signature_item_desc : - Ast_410.Parsetree.signature_item_desc -> - Ast_411.Parsetree.signature_item_desc - = - function - | Ast_410.Parsetree.Psig_value x0 -> - Ast_411.Parsetree.Psig_value (copy_value_description x0) - | Ast_410.Parsetree.Psig_type (x0, x1) -> - Ast_411.Parsetree.Psig_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_410.Parsetree.Psig_typesubst x0 -> - Ast_411.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) - | Ast_410.Parsetree.Psig_typext x0 -> - Ast_411.Parsetree.Psig_typext (copy_type_extension x0) - | Ast_410.Parsetree.Psig_exception x0 -> - Ast_411.Parsetree.Psig_exception (copy_type_exception x0) - | Ast_410.Parsetree.Psig_module x0 -> - Ast_411.Parsetree.Psig_module (copy_module_declaration x0) - | Ast_410.Parsetree.Psig_modsubst x0 -> - Ast_411.Parsetree.Psig_modsubst (copy_module_substitution x0) - | Ast_410.Parsetree.Psig_recmodule x0 -> - Ast_411.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) - | Ast_410.Parsetree.Psig_modtype x0 -> - Ast_411.Parsetree.Psig_modtype (copy_module_type_declaration x0) - | Ast_410.Parsetree.Psig_open x0 -> - Ast_411.Parsetree.Psig_open (copy_open_description x0) - | Ast_410.Parsetree.Psig_include x0 -> - Ast_411.Parsetree.Psig_include (copy_include_description x0) - | Ast_410.Parsetree.Psig_class x0 -> - Ast_411.Parsetree.Psig_class (List.map copy_class_description x0) - | Ast_410.Parsetree.Psig_class_type x0 -> - Ast_411.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | Ast_410.Parsetree.Psig_attribute x0 -> - Ast_411.Parsetree.Psig_attribute (copy_attribute x0) - | Ast_410.Parsetree.Psig_extension (x0, x1) -> - Ast_411.Parsetree.Psig_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_class_type_declaration : - Ast_410.Parsetree.class_type_declaration -> - Ast_411.Parsetree.class_type_declaration - = fun x -> copy_class_infos copy_class_type x -and copy_class_description : - Ast_410.Parsetree.class_description -> Ast_411.Parsetree.class_description - = fun x -> copy_class_infos copy_class_type x -and copy_class_type : - Ast_410.Parsetree.class_type -> Ast_411.Parsetree.class_type = - fun - { Ast_410.Parsetree.pcty_desc = pcty_desc; - Ast_410.Parsetree.pcty_loc = pcty_loc; - Ast_410.Parsetree.pcty_attributes = pcty_attributes } - -> - { - Ast_411.Parsetree.pcty_desc = (copy_class_type_desc pcty_desc); - Ast_411.Parsetree.pcty_loc = (copy_location pcty_loc); - Ast_411.Parsetree.pcty_attributes = (copy_attributes pcty_attributes) - } -and copy_class_type_desc : - Ast_410.Parsetree.class_type_desc -> Ast_411.Parsetree.class_type_desc = - function - | Ast_410.Parsetree.Pcty_constr (x0, x1) -> - Ast_411.Parsetree.Pcty_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_410.Parsetree.Pcty_signature x0 -> - Ast_411.Parsetree.Pcty_signature (copy_class_signature x0) - | Ast_410.Parsetree.Pcty_arrow (x0, x1, x2) -> - Ast_411.Parsetree.Pcty_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_class_type x2)) - | Ast_410.Parsetree.Pcty_extension x0 -> - Ast_411.Parsetree.Pcty_extension (copy_extension x0) - | Ast_410.Parsetree.Pcty_open (x0, x1) -> - Ast_411.Parsetree.Pcty_open - ((copy_open_description x0), (copy_class_type x1)) -and copy_class_signature : - Ast_410.Parsetree.class_signature -> Ast_411.Parsetree.class_signature = - fun - { Ast_410.Parsetree.pcsig_self = pcsig_self; - Ast_410.Parsetree.pcsig_fields = pcsig_fields } - -> - { - Ast_411.Parsetree.pcsig_self = (copy_core_type pcsig_self); - Ast_411.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } -and copy_class_type_field : - Ast_410.Parsetree.class_type_field -> Ast_411.Parsetree.class_type_field = - fun - { Ast_410.Parsetree.pctf_desc = pctf_desc; - Ast_410.Parsetree.pctf_loc = pctf_loc; - Ast_410.Parsetree.pctf_attributes = pctf_attributes } - -> - { - Ast_411.Parsetree.pctf_desc = (copy_class_type_field_desc pctf_desc); - Ast_411.Parsetree.pctf_loc = (copy_location pctf_loc); - Ast_411.Parsetree.pctf_attributes = (copy_attributes pctf_attributes) - } -and copy_class_type_field_desc : - Ast_410.Parsetree.class_type_field_desc -> - Ast_411.Parsetree.class_type_field_desc - = - function - | Ast_410.Parsetree.Pctf_inherit x0 -> - Ast_411.Parsetree.Pctf_inherit (copy_class_type x0) - | Ast_410.Parsetree.Pctf_val x0 -> - Ast_411.Parsetree.Pctf_val - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_410.Parsetree.Pctf_method x0 -> - Ast_411.Parsetree.Pctf_method - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_410.Parsetree.Pctf_constraint x0 -> - Ast_411.Parsetree.Pctf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_410.Parsetree.Pctf_attribute x0 -> - Ast_411.Parsetree.Pctf_attribute (copy_attribute x0) - | Ast_410.Parsetree.Pctf_extension x0 -> - Ast_411.Parsetree.Pctf_extension (copy_extension x0) -and copy_extension : - Ast_410.Parsetree.extension -> Ast_411.Parsetree.extension = - fun x -> - let (x0, x1) = x in ((copy_loc (fun x -> x) x0), (copy_payload x1)) -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_410.Parsetree.class_infos -> 'g0 Ast_411.Parsetree.class_infos - = - fun f0 -> - fun - { Ast_410.Parsetree.pci_virt = pci_virt; - Ast_410.Parsetree.pci_params = pci_params; - Ast_410.Parsetree.pci_name = pci_name; - Ast_410.Parsetree.pci_expr = pci_expr; - Ast_410.Parsetree.pci_loc = pci_loc; - Ast_410.Parsetree.pci_attributes = pci_attributes } - -> - { - Ast_411.Parsetree.pci_virt = (copy_virtual_flag pci_virt); - Ast_411.Parsetree.pci_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - pci_params); - Ast_411.Parsetree.pci_name = (copy_loc (fun x -> x) pci_name); - Ast_411.Parsetree.pci_expr = (f0 pci_expr); - Ast_411.Parsetree.pci_loc = (copy_location pci_loc); - Ast_411.Parsetree.pci_attributes = (copy_attributes pci_attributes) - } -and copy_virtual_flag : - Ast_410.Asttypes.virtual_flag -> Ast_411.Asttypes.virtual_flag = - function - | Ast_410.Asttypes.Virtual -> Ast_411.Asttypes.Virtual - | Ast_410.Asttypes.Concrete -> Ast_411.Asttypes.Concrete -and copy_include_description : - Ast_410.Parsetree.include_description -> - Ast_411.Parsetree.include_description - = fun x -> copy_include_infos copy_module_type x -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_410.Parsetree.include_infos -> - 'g0 Ast_411.Parsetree.include_infos - = - fun f0 -> - fun - { Ast_410.Parsetree.pincl_mod = pincl_mod; - Ast_410.Parsetree.pincl_loc = pincl_loc; - Ast_410.Parsetree.pincl_attributes = pincl_attributes } - -> - { - Ast_411.Parsetree.pincl_mod = (f0 pincl_mod); - Ast_411.Parsetree.pincl_loc = (copy_location pincl_loc); - Ast_411.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } -and copy_open_description : - Ast_410.Parsetree.open_description -> Ast_411.Parsetree.open_description = - fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x -and copy_open_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_410.Parsetree.open_infos -> 'g0 Ast_411.Parsetree.open_infos - = - fun f0 -> - fun - { Ast_410.Parsetree.popen_expr = popen_expr; - Ast_410.Parsetree.popen_override = popen_override; - Ast_410.Parsetree.popen_loc = popen_loc; - Ast_410.Parsetree.popen_attributes = popen_attributes } - -> - { - Ast_411.Parsetree.popen_expr = (f0 popen_expr); - Ast_411.Parsetree.popen_override = - (copy_override_flag popen_override); - Ast_411.Parsetree.popen_loc = (copy_location popen_loc); - Ast_411.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } -and copy_override_flag : - Ast_410.Asttypes.override_flag -> Ast_411.Asttypes.override_flag = - function - | Ast_410.Asttypes.Override -> Ast_411.Asttypes.Override - | Ast_410.Asttypes.Fresh -> Ast_411.Asttypes.Fresh -and copy_module_type_declaration : - Ast_410.Parsetree.module_type_declaration -> - Ast_411.Parsetree.module_type_declaration - = - fun - { Ast_410.Parsetree.pmtd_name = pmtd_name; - Ast_410.Parsetree.pmtd_type = pmtd_type; - Ast_410.Parsetree.pmtd_attributes = pmtd_attributes; - Ast_410.Parsetree.pmtd_loc = pmtd_loc } - -> - { - Ast_411.Parsetree.pmtd_name = (copy_loc (fun x -> x) pmtd_name); - Ast_411.Parsetree.pmtd_type = (Option.map copy_module_type pmtd_type); - Ast_411.Parsetree.pmtd_attributes = (copy_attributes pmtd_attributes); - Ast_411.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } -and copy_module_substitution : - Ast_410.Parsetree.module_substitution -> - Ast_411.Parsetree.module_substitution - = - fun - { Ast_410.Parsetree.pms_name = pms_name; - Ast_410.Parsetree.pms_manifest = pms_manifest; - Ast_410.Parsetree.pms_attributes = pms_attributes; - Ast_410.Parsetree.pms_loc = pms_loc } - -> - { - Ast_411.Parsetree.pms_name = (copy_loc (fun x -> x) pms_name); - Ast_411.Parsetree.pms_manifest = - (copy_loc copy_Longident_t pms_manifest); - Ast_411.Parsetree.pms_attributes = (copy_attributes pms_attributes); - Ast_411.Parsetree.pms_loc = (copy_location pms_loc) - } -and copy_module_declaration : - Ast_410.Parsetree.module_declaration -> - Ast_411.Parsetree.module_declaration - = - fun - { Ast_410.Parsetree.pmd_name = pmd_name; - Ast_410.Parsetree.pmd_type = pmd_type; - Ast_410.Parsetree.pmd_attributes = pmd_attributes; - Ast_410.Parsetree.pmd_loc = pmd_loc } - -> - { - Ast_411.Parsetree.pmd_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name); - Ast_411.Parsetree.pmd_type = (copy_module_type pmd_type); - Ast_411.Parsetree.pmd_attributes = (copy_attributes pmd_attributes); - Ast_411.Parsetree.pmd_loc = (copy_location pmd_loc) - } -and copy_type_exception : - Ast_410.Parsetree.type_exception -> Ast_411.Parsetree.type_exception = - fun - { Ast_410.Parsetree.ptyexn_constructor = ptyexn_constructor; - Ast_410.Parsetree.ptyexn_loc = ptyexn_loc; - Ast_410.Parsetree.ptyexn_attributes = ptyexn_attributes } - -> - { - Ast_411.Parsetree.ptyexn_constructor = - (copy_extension_constructor ptyexn_constructor); - Ast_411.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); - Ast_411.Parsetree.ptyexn_attributes = - (copy_attributes ptyexn_attributes) - } -and copy_type_extension : - Ast_410.Parsetree.type_extension -> Ast_411.Parsetree.type_extension = - fun - { Ast_410.Parsetree.ptyext_path = ptyext_path; - Ast_410.Parsetree.ptyext_params = ptyext_params; - Ast_410.Parsetree.ptyext_constructors = ptyext_constructors; - Ast_410.Parsetree.ptyext_private = ptyext_private; - Ast_410.Parsetree.ptyext_loc = ptyext_loc; - Ast_410.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - Ast_411.Parsetree.ptyext_path = (copy_loc copy_Longident_t ptyext_path); - Ast_411.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - ptyext_params); - Ast_411.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor ptyext_constructors); - Ast_411.Parsetree.ptyext_private = (copy_private_flag ptyext_private); - Ast_411.Parsetree.ptyext_loc = (copy_location ptyext_loc); - Ast_411.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } -and copy_extension_constructor : - Ast_410.Parsetree.extension_constructor -> - Ast_411.Parsetree.extension_constructor - = - fun - { Ast_410.Parsetree.pext_name = pext_name; - Ast_410.Parsetree.pext_kind = pext_kind; - Ast_410.Parsetree.pext_loc = pext_loc; - Ast_410.Parsetree.pext_attributes = pext_attributes } - -> - { - Ast_411.Parsetree.pext_name = (copy_loc (fun x -> x) pext_name); - Ast_411.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - Ast_411.Parsetree.pext_loc = (copy_location pext_loc); - Ast_411.Parsetree.pext_attributes = (copy_attributes pext_attributes) - } -and copy_extension_constructor_kind : - Ast_410.Parsetree.extension_constructor_kind -> - Ast_411.Parsetree.extension_constructor_kind - = - function - | Ast_410.Parsetree.Pext_decl (x0, x1) -> - Ast_411.Parsetree.Pext_decl - ((copy_constructor_arguments x0), (Option.map copy_core_type x1)) - | Ast_410.Parsetree.Pext_rebind x0 -> - Ast_411.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) -and copy_type_declaration : - Ast_410.Parsetree.type_declaration -> Ast_411.Parsetree.type_declaration = - fun - { Ast_410.Parsetree.ptype_name = ptype_name; - Ast_410.Parsetree.ptype_params = ptype_params; - Ast_410.Parsetree.ptype_cstrs = ptype_cstrs; - Ast_410.Parsetree.ptype_kind = ptype_kind; - Ast_410.Parsetree.ptype_private = ptype_private; - Ast_410.Parsetree.ptype_manifest = ptype_manifest; - Ast_410.Parsetree.ptype_attributes = ptype_attributes; - Ast_410.Parsetree.ptype_loc = ptype_loc } - -> - { - Ast_411.Parsetree.ptype_name = (copy_loc (fun x -> x) ptype_name); - Ast_411.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - ptype_params); - Ast_411.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0, x1, x2) = x in - ((copy_core_type x0), (copy_core_type x1), (copy_location x2))) - ptype_cstrs); - Ast_411.Parsetree.ptype_kind = (copy_type_kind ptype_kind); - Ast_411.Parsetree.ptype_private = (copy_private_flag ptype_private); - Ast_411.Parsetree.ptype_manifest = - (Option.map copy_core_type ptype_manifest); - Ast_411.Parsetree.ptype_attributes = (copy_attributes ptype_attributes); - Ast_411.Parsetree.ptype_loc = (copy_location ptype_loc) - } -and copy_private_flag : - Ast_410.Asttypes.private_flag -> Ast_411.Asttypes.private_flag = - function - | Ast_410.Asttypes.Private -> Ast_411.Asttypes.Private - | Ast_410.Asttypes.Public -> Ast_411.Asttypes.Public -and copy_type_kind : - Ast_410.Parsetree.type_kind -> Ast_411.Parsetree.type_kind = - function - | Ast_410.Parsetree.Ptype_abstract -> Ast_411.Parsetree.Ptype_abstract - | Ast_410.Parsetree.Ptype_variant x0 -> - Ast_411.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | Ast_410.Parsetree.Ptype_record x0 -> - Ast_411.Parsetree.Ptype_record (List.map copy_label_declaration x0) - | Ast_410.Parsetree.Ptype_open -> Ast_411.Parsetree.Ptype_open -and copy_constructor_declaration : - Ast_410.Parsetree.constructor_declaration -> - Ast_411.Parsetree.constructor_declaration - = - fun - { Ast_410.Parsetree.pcd_name = pcd_name; - Ast_410.Parsetree.pcd_args = pcd_args; - Ast_410.Parsetree.pcd_res = pcd_res; - Ast_410.Parsetree.pcd_loc = pcd_loc; - Ast_410.Parsetree.pcd_attributes = pcd_attributes } - -> - { - Ast_411.Parsetree.pcd_name = (copy_loc (fun x -> x) pcd_name); - Ast_411.Parsetree.pcd_args = (copy_constructor_arguments pcd_args); - Ast_411.Parsetree.pcd_res = (Option.map copy_core_type pcd_res); - Ast_411.Parsetree.pcd_loc = (copy_location pcd_loc); - Ast_411.Parsetree.pcd_attributes = (copy_attributes pcd_attributes) - } -and copy_constructor_arguments : - Ast_410.Parsetree.constructor_arguments -> - Ast_411.Parsetree.constructor_arguments - = - function - | Ast_410.Parsetree.Pcstr_tuple x0 -> - Ast_411.Parsetree.Pcstr_tuple (List.map copy_core_type x0) - | Ast_410.Parsetree.Pcstr_record x0 -> - Ast_411.Parsetree.Pcstr_record (List.map copy_label_declaration x0) -and copy_label_declaration : - Ast_410.Parsetree.label_declaration -> Ast_411.Parsetree.label_declaration - = - fun - { Ast_410.Parsetree.pld_name = pld_name; - Ast_410.Parsetree.pld_mutable = pld_mutable; - Ast_410.Parsetree.pld_type = pld_type; - Ast_410.Parsetree.pld_loc = pld_loc; - Ast_410.Parsetree.pld_attributes = pld_attributes } - -> - { - Ast_411.Parsetree.pld_name = (copy_loc (fun x -> x) pld_name); - Ast_411.Parsetree.pld_mutable = (copy_mutable_flag pld_mutable); - Ast_411.Parsetree.pld_type = (copy_core_type pld_type); - Ast_411.Parsetree.pld_loc = (copy_location pld_loc); - Ast_411.Parsetree.pld_attributes = (copy_attributes pld_attributes) - } -and copy_mutable_flag : - Ast_410.Asttypes.mutable_flag -> Ast_411.Asttypes.mutable_flag = - function - | Ast_410.Asttypes.Immutable -> Ast_411.Asttypes.Immutable - | Ast_410.Asttypes.Mutable -> Ast_411.Asttypes.Mutable -and copy_variance : Ast_410.Asttypes.variance -> Ast_411.Asttypes.variance = - function - | Ast_410.Asttypes.Covariant -> Ast_411.Asttypes.Covariant - | Ast_410.Asttypes.Contravariant -> Ast_411.Asttypes.Contravariant - | Ast_410.Asttypes.Invariant -> Ast_411.Asttypes.Invariant -and copy_value_description : - Ast_410.Parsetree.value_description -> Ast_411.Parsetree.value_description - = - fun - { Ast_410.Parsetree.pval_name = pval_name; - Ast_410.Parsetree.pval_type = pval_type; - Ast_410.Parsetree.pval_prim = pval_prim; - Ast_410.Parsetree.pval_attributes = pval_attributes; - Ast_410.Parsetree.pval_loc = pval_loc } - -> - { - Ast_411.Parsetree.pval_name = (copy_loc (fun x -> x) pval_name); - Ast_411.Parsetree.pval_type = (copy_core_type pval_type); - Ast_411.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - Ast_411.Parsetree.pval_attributes = (copy_attributes pval_attributes); - Ast_411.Parsetree.pval_loc = (copy_location pval_loc) - } -and copy_object_field_desc : - Ast_410.Parsetree.object_field_desc -> Ast_411.Parsetree.object_field_desc - = - function - | Ast_410.Parsetree.Otag (x0, x1) -> - Ast_411.Parsetree.Otag ((copy_loc copy_label x0), (copy_core_type x1)) - | Ast_410.Parsetree.Oinherit x0 -> - Ast_411.Parsetree.Oinherit (copy_core_type x0) -and copy_arg_label : Ast_410.Asttypes.arg_label -> Ast_411.Asttypes.arg_label - = - function - | Ast_410.Asttypes.Nolabel -> Ast_411.Asttypes.Nolabel - | Ast_410.Asttypes.Labelled x0 -> Ast_411.Asttypes.Labelled x0 - | Ast_410.Asttypes.Optional x0 -> Ast_411.Asttypes.Optional x0 -and copy_closed_flag : - Ast_410.Asttypes.closed_flag -> Ast_411.Asttypes.closed_flag = - function - | Ast_410.Asttypes.Closed -> Ast_411.Asttypes.Closed - | Ast_410.Asttypes.Open -> Ast_411.Asttypes.Open -and copy_label : Ast_410.Asttypes.label -> Ast_411.Asttypes.label = - fun x -> x -and copy_rec_flag : Ast_410.Asttypes.rec_flag -> Ast_411.Asttypes.rec_flag = - function - | Ast_410.Asttypes.Nonrecursive -> Ast_411.Asttypes.Nonrecursive - | Ast_410.Asttypes.Recursive -> Ast_411.Asttypes.Recursive -and copy_constant : Ast_410.Parsetree.constant -> Ast_411.Parsetree.constant - = - function - | Ast_410.Parsetree.Pconst_integer (x0, x1) -> - Ast_411.Parsetree.Pconst_integer (x0, (Option.map (fun x -> x) x1)) - | Ast_410.Parsetree.Pconst_char x0 -> Ast_411.Parsetree.Pconst_char x0 - | Ast_410.Parsetree.Pconst_string (x0, x1) -> - Ast_411.Parsetree.Pconst_string (x0, Location.none, (Option.map (fun x -> x) x1)) - | Ast_410.Parsetree.Pconst_float (x0, x1) -> - Ast_411.Parsetree.Pconst_float (x0, (Option.map (fun x -> x) x1)) -and copy_Longident_t : Ast_410.Longident.t -> Ast_411.Longident.t = - function - | Ast_410.Longident.Lident x0 -> Ast_411.Longident.Lident x0 - | Ast_410.Longident.Ldot (x0, x1) -> - Ast_411.Longident.Ldot ((copy_Longident_t x0), x1) - | Ast_410.Longident.Lapply (x0, x1) -> - Ast_411.Longident.Lapply ((copy_Longident_t x0), (copy_Longident_t x1)) -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 Ast_410.Asttypes.loc -> 'g0 Ast_411.Asttypes.loc - = - fun f0 -> - fun { Ast_410.Asttypes.txt = txt; Ast_410.Asttypes.loc = loc } -> - { - Ast_411.Asttypes.txt = (f0 txt); - Ast_411.Asttypes.loc = (copy_location loc) - } -and copy_location : Ast_410.Location.t -> Ast_411.Location.t = - fun - { Ast_410.Location.loc_start = loc_start; - Ast_410.Location.loc_end = loc_end; - Ast_410.Location.loc_ghost = loc_ghost } - -> - { - Ast_411.Location.loc_start = (copy_position loc_start); - Ast_411.Location.loc_end = (copy_position loc_end); - Ast_411.Location.loc_ghost = loc_ghost - } -and copy_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum - } diff --git a/src/vendored-omp/src/migrate_parsetree_411_410.ml b/src/vendored-omp/src/migrate_parsetree_411_410.ml index 6fefc35f8..0c0e10c8c 100644 --- a/src/vendored-omp/src/migrate_parsetree_411_410.ml +++ b/src/vendored-omp/src/migrate_parsetree_411_410.ml @@ -15,128 +15,3 @@ include Migrate_parsetree_411_410_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload"; - "binding_op"; "module_substitution"; "open_declaration"; "type_exception" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - binding_op; - module_substitution; - open_declaration; - type_exception; - (*$*) - constant; - } as mapper) -> - let _ = constant in - let module Def = Migrate_parsetree_def in - let module R = Migrate_parsetree_410_411_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - binding_op = (fun _ x -> copy_binding_op (binding_op mapper (R.copy_binding_op x))); - module_substitution = (fun _ x -> copy_module_substitution (module_substitution mapper (R.copy_module_substitution x))); - open_declaration = (fun _ x -> copy_open_declaration (open_declaration mapper (R.copy_open_declaration x))); - type_exception = (fun _ x -> copy_type_exception (type_exception mapper (R.copy_type_exception x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_411_410_migrate.ml b/src/vendored-omp/src/migrate_parsetree_411_410_migrate.ml index b0687a92f..b0de66680 100644 --- a/src/vendored-omp/src/migrate_parsetree_411_410_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_411_410_migrate.ml @@ -165,6 +165,11 @@ and copy_out_extension_constructor : (Option.map copy_out_type oext_ret_type); Ast_410.Outcometree.oext_private = (copy_private_flag oext_private) } +and copy_private_flag : + Ast_411.Asttypes.private_flag -> Ast_410.Asttypes.private_flag = + function + | Ast_411.Asttypes.Private -> Ast_410.Asttypes.Private + | Ast_411.Asttypes.Public -> Ast_410.Asttypes.Public and copy_out_rec_status : Ast_411.Outcometree.out_rec_status -> Ast_410.Outcometree.out_rec_status = function @@ -316,1208 +321,3 @@ and copy_out_name : Ast_411.Outcometree.out_name -> Ast_410.Outcometree.out_name = fun { Ast_411.Outcometree.printed_name = printed_name } -> { Ast_410.Outcometree.printed_name = printed_name } -and copy_toplevel_phrase : - Ast_411.Parsetree.toplevel_phrase -> Ast_410.Parsetree.toplevel_phrase = - function - | Ast_411.Parsetree.Ptop_def x0 -> - Ast_410.Parsetree.Ptop_def (copy_structure x0) - | Ast_411.Parsetree.Ptop_dir x0 -> - Ast_410.Parsetree.Ptop_dir (copy_toplevel_directive x0) -and copy_toplevel_directive : - Ast_411.Parsetree.toplevel_directive -> - Ast_410.Parsetree.toplevel_directive - = - fun - { Ast_411.Parsetree.pdir_name = pdir_name; - Ast_411.Parsetree.pdir_arg = pdir_arg; - Ast_411.Parsetree.pdir_loc = pdir_loc } - -> - { - Ast_410.Parsetree.pdir_name = (copy_loc (fun x -> x) pdir_name); - Ast_410.Parsetree.pdir_arg = - (Option.map copy_directive_argument pdir_arg); - Ast_410.Parsetree.pdir_loc = (copy_location pdir_loc) - } -and copy_directive_argument : - Ast_411.Parsetree.directive_argument -> - Ast_410.Parsetree.directive_argument - = - fun - { Ast_411.Parsetree.pdira_desc = pdira_desc; - Ast_411.Parsetree.pdira_loc = pdira_loc } - -> - { - Ast_410.Parsetree.pdira_desc = - (copy_directive_argument_desc pdira_desc); - Ast_410.Parsetree.pdira_loc = (copy_location pdira_loc) - } -and copy_directive_argument_desc : - Ast_411.Parsetree.directive_argument_desc -> - Ast_410.Parsetree.directive_argument_desc - = - function - | Ast_411.Parsetree.Pdir_string x0 -> Ast_410.Parsetree.Pdir_string x0 - | Ast_411.Parsetree.Pdir_int (x0, x1) -> - Ast_410.Parsetree.Pdir_int (x0, (Option.map (fun x -> x) x1)) - | Ast_411.Parsetree.Pdir_ident x0 -> - Ast_410.Parsetree.Pdir_ident (copy_Longident_t x0) - | Ast_411.Parsetree.Pdir_bool x0 -> Ast_410.Parsetree.Pdir_bool x0 -and copy_expression : - Ast_411.Parsetree.expression -> Ast_410.Parsetree.expression = - fun - { Ast_411.Parsetree.pexp_desc = pexp_desc; - Ast_411.Parsetree.pexp_loc = pexp_loc; - Ast_411.Parsetree.pexp_loc_stack = pexp_loc_stack; - Ast_411.Parsetree.pexp_attributes = pexp_attributes } - -> - { - Ast_410.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - Ast_410.Parsetree.pexp_loc = (copy_location pexp_loc); - Ast_410.Parsetree.pexp_loc_stack = (copy_location_stack pexp_loc_stack); - Ast_410.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } -and copy_expr x = copy_expression x -and copy_expression_desc : - Ast_411.Parsetree.expression_desc -> Ast_410.Parsetree.expression_desc = - function - | Ast_411.Parsetree.Pexp_ident x0 -> - Ast_410.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) - | Ast_411.Parsetree.Pexp_constant x0 -> - Ast_410.Parsetree.Pexp_constant (copy_constant x0) - | Ast_411.Parsetree.Pexp_let (x0, x1, x2) -> - Ast_410.Parsetree.Pexp_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_expression x2)) - | Ast_411.Parsetree.Pexp_function x0 -> - Ast_410.Parsetree.Pexp_function (List.map copy_case x0) - | Ast_411.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_410.Parsetree.Pexp_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_expression x3)) - | Ast_411.Parsetree.Pexp_apply (x0, x1) -> - Ast_410.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_411.Parsetree.Pexp_match (x0, x1) -> - Ast_410.Parsetree.Pexp_match - ((copy_expression x0), (List.map copy_case x1)) - | Ast_411.Parsetree.Pexp_try (x0, x1) -> - Ast_410.Parsetree.Pexp_try - ((copy_expression x0), (List.map copy_case x1)) - | Ast_411.Parsetree.Pexp_tuple x0 -> - Ast_410.Parsetree.Pexp_tuple (List.map copy_expression x0) - | Ast_411.Parsetree.Pexp_construct (x0, x1) -> - Ast_410.Parsetree.Pexp_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_expression x1)) - | Ast_411.Parsetree.Pexp_variant (x0, x1) -> - Ast_410.Parsetree.Pexp_variant - ((copy_label x0), (Option.map copy_expression x1)) - | Ast_411.Parsetree.Pexp_record (x0, x1) -> - Ast_410.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_expression x1))) x0), - (Option.map copy_expression x1)) - | Ast_411.Parsetree.Pexp_field (x0, x1) -> - Ast_410.Parsetree.Pexp_field - ((copy_expression x0), (copy_loc copy_Longident_t x1)) - | Ast_411.Parsetree.Pexp_setfield (x0, x1, x2) -> - Ast_410.Parsetree.Pexp_setfield - ((copy_expression x0), (copy_loc copy_Longident_t x1), - (copy_expression x2)) - | Ast_411.Parsetree.Pexp_array x0 -> - Ast_410.Parsetree.Pexp_array (List.map copy_expression x0) - | Ast_411.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> - Ast_410.Parsetree.Pexp_ifthenelse - ((copy_expression x0), (copy_expression x1), - (Option.map copy_expression x2)) - | Ast_411.Parsetree.Pexp_sequence (x0, x1) -> - Ast_410.Parsetree.Pexp_sequence - ((copy_expression x0), (copy_expression x1)) - | Ast_411.Parsetree.Pexp_while (x0, x1) -> - Ast_410.Parsetree.Pexp_while - ((copy_expression x0), (copy_expression x1)) - | Ast_411.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> - Ast_410.Parsetree.Pexp_for - ((copy_pattern x0), (copy_expression x1), (copy_expression x2), - (copy_direction_flag x3), (copy_expression x4)) - | Ast_411.Parsetree.Pexp_constraint (x0, x1) -> - Ast_410.Parsetree.Pexp_constraint - ((copy_expression x0), (copy_core_type x1)) - | Ast_411.Parsetree.Pexp_coerce (x0, x1, x2) -> - Ast_410.Parsetree.Pexp_coerce - ((copy_expression x0), (Option.map copy_core_type x1), - (copy_core_type x2)) - | Ast_411.Parsetree.Pexp_send (x0, x1) -> - Ast_410.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc copy_label x1)) - | Ast_411.Parsetree.Pexp_new x0 -> - Ast_410.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) - | Ast_411.Parsetree.Pexp_setinstvar (x0, x1) -> - Ast_410.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), (copy_expression x1)) - | Ast_411.Parsetree.Pexp_override x0 -> - Ast_410.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_label x0), (copy_expression x1))) x0) - | Ast_411.Parsetree.Pexp_letmodule (x0, x1, x2) -> - Ast_410.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_expr x1), (copy_expression x2)) - | Ast_411.Parsetree.Pexp_letexception (x0, x1) -> - Ast_410.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), (copy_expression x1)) - | Ast_411.Parsetree.Pexp_assert x0 -> - Ast_410.Parsetree.Pexp_assert (copy_expression x0) - | Ast_411.Parsetree.Pexp_lazy x0 -> - Ast_410.Parsetree.Pexp_lazy (copy_expression x0) - | Ast_411.Parsetree.Pexp_poly (x0, x1) -> - Ast_410.Parsetree.Pexp_poly - ((copy_expression x0), (Option.map copy_core_type x1)) - | Ast_411.Parsetree.Pexp_object x0 -> - Ast_410.Parsetree.Pexp_object (copy_class_structure x0) - | Ast_411.Parsetree.Pexp_newtype (x0, x1) -> - Ast_410.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | Ast_411.Parsetree.Pexp_pack x0 -> - Ast_410.Parsetree.Pexp_pack (copy_module_expr x0) - | Ast_411.Parsetree.Pexp_open (x0, x1) -> - Ast_410.Parsetree.Pexp_open - ((copy_open_declaration x0), (copy_expression x1)) - | Ast_411.Parsetree.Pexp_letop x0 -> - Ast_410.Parsetree.Pexp_letop (copy_letop x0) - | Ast_411.Parsetree.Pexp_extension x0 -> - Ast_410.Parsetree.Pexp_extension (copy_extension x0) - | Ast_411.Parsetree.Pexp_unreachable -> Ast_410.Parsetree.Pexp_unreachable -and copy_letop : Ast_411.Parsetree.letop -> Ast_410.Parsetree.letop = - fun - { Ast_411.Parsetree.let_ = let_; Ast_411.Parsetree.ands = ands; - Ast_411.Parsetree.body = body } - -> - { - Ast_410.Parsetree.let_ = (copy_binding_op let_); - Ast_410.Parsetree.ands = (List.map copy_binding_op ands); - Ast_410.Parsetree.body = (copy_expression body) - } -and copy_binding_op : - Ast_411.Parsetree.binding_op -> Ast_410.Parsetree.binding_op = - fun - { Ast_411.Parsetree.pbop_op = pbop_op; - Ast_411.Parsetree.pbop_pat = pbop_pat; - Ast_411.Parsetree.pbop_exp = pbop_exp; - Ast_411.Parsetree.pbop_loc = pbop_loc } - -> - { - Ast_410.Parsetree.pbop_op = (copy_loc (fun x -> x) pbop_op); - Ast_410.Parsetree.pbop_pat = (copy_pattern pbop_pat); - Ast_410.Parsetree.pbop_exp = (copy_expression pbop_exp); - Ast_410.Parsetree.pbop_loc = (copy_location pbop_loc) - } -and copy_direction_flag : - Ast_411.Asttypes.direction_flag -> Ast_410.Asttypes.direction_flag = - function - | Ast_411.Asttypes.Upto -> Ast_410.Asttypes.Upto - | Ast_411.Asttypes.Downto -> Ast_410.Asttypes.Downto -and copy_case : Ast_411.Parsetree.case -> Ast_410.Parsetree.case = - fun - { Ast_411.Parsetree.pc_lhs = pc_lhs; - Ast_411.Parsetree.pc_guard = pc_guard; - Ast_411.Parsetree.pc_rhs = pc_rhs } - -> - { - Ast_410.Parsetree.pc_lhs = (copy_pattern pc_lhs); - Ast_410.Parsetree.pc_guard = (Option.map copy_expression pc_guard); - Ast_410.Parsetree.pc_rhs = (copy_expression pc_rhs) - } -and copy_cases : Ast_411.Parsetree.case list -> Ast_410.Parsetree.case list = - fun x -> List.map copy_case x -and copy_value_binding : - Ast_411.Parsetree.value_binding -> Ast_410.Parsetree.value_binding = - fun - { Ast_411.Parsetree.pvb_pat = pvb_pat; - Ast_411.Parsetree.pvb_expr = pvb_expr; - Ast_411.Parsetree.pvb_attributes = pvb_attributes; - Ast_411.Parsetree.pvb_loc = pvb_loc } - -> - { - Ast_410.Parsetree.pvb_pat = (copy_pattern pvb_pat); - Ast_410.Parsetree.pvb_expr = (copy_expression pvb_expr); - Ast_410.Parsetree.pvb_attributes = (copy_attributes pvb_attributes); - Ast_410.Parsetree.pvb_loc = (copy_location pvb_loc) - } -and copy_pattern : Ast_411.Parsetree.pattern -> Ast_410.Parsetree.pattern = - fun - { Ast_411.Parsetree.ppat_desc = ppat_desc; - Ast_411.Parsetree.ppat_loc = ppat_loc; - Ast_411.Parsetree.ppat_loc_stack = ppat_loc_stack; - Ast_411.Parsetree.ppat_attributes = ppat_attributes } - -> - { - Ast_410.Parsetree.ppat_desc = (copy_pattern_desc ppat_desc); - Ast_410.Parsetree.ppat_loc = (copy_location ppat_loc); - Ast_410.Parsetree.ppat_loc_stack = (copy_location_stack ppat_loc_stack); - Ast_410.Parsetree.ppat_attributes = (copy_attributes ppat_attributes) - } -and copy_pat x = copy_pattern x -and copy_pattern_desc : - Ast_411.Parsetree.pattern_desc -> Ast_410.Parsetree.pattern_desc = - function - | Ast_411.Parsetree.Ppat_any -> Ast_410.Parsetree.Ppat_any - | Ast_411.Parsetree.Ppat_var x0 -> - Ast_410.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | Ast_411.Parsetree.Ppat_alias (x0, x1) -> - Ast_410.Parsetree.Ppat_alias - ((copy_pattern x0), (copy_loc (fun x -> x) x1)) - | Ast_411.Parsetree.Ppat_constant x0 -> - Ast_410.Parsetree.Ppat_constant (copy_constant x0) - | Ast_411.Parsetree.Ppat_interval (x0, x1) -> - Ast_410.Parsetree.Ppat_interval - ((copy_constant x0), (copy_constant x1)) - | Ast_411.Parsetree.Ppat_tuple x0 -> - Ast_410.Parsetree.Ppat_tuple (List.map copy_pattern x0) - | Ast_411.Parsetree.Ppat_construct (x0, x1) -> - Ast_410.Parsetree.Ppat_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_pattern x1)) - | Ast_411.Parsetree.Ppat_variant (x0, x1) -> - Ast_410.Parsetree.Ppat_variant - ((copy_label x0), (Option.map copy_pattern x1)) - | Ast_411.Parsetree.Ppat_record (x0, x1) -> - Ast_410.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | Ast_411.Parsetree.Ppat_array x0 -> - Ast_410.Parsetree.Ppat_array (List.map copy_pattern x0) - | Ast_411.Parsetree.Ppat_or (x0, x1) -> - Ast_410.Parsetree.Ppat_or ((copy_pattern x0), (copy_pattern x1)) - | Ast_411.Parsetree.Ppat_constraint (x0, x1) -> - Ast_410.Parsetree.Ppat_constraint - ((copy_pattern x0), (copy_core_type x1)) - | Ast_411.Parsetree.Ppat_type x0 -> - Ast_410.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) - | Ast_411.Parsetree.Ppat_lazy x0 -> - Ast_410.Parsetree.Ppat_lazy (copy_pattern x0) - | Ast_411.Parsetree.Ppat_unpack x0 -> - Ast_410.Parsetree.Ppat_unpack - (copy_loc (fun x -> Option.map (fun x -> x) x) x0) - | Ast_411.Parsetree.Ppat_exception x0 -> - Ast_410.Parsetree.Ppat_exception (copy_pattern x0) - | Ast_411.Parsetree.Ppat_extension x0 -> - Ast_410.Parsetree.Ppat_extension (copy_extension x0) - | Ast_411.Parsetree.Ppat_open (x0, x1) -> - Ast_410.Parsetree.Ppat_open - ((copy_loc copy_Longident_t x0), (copy_pattern x1)) -and copy_core_type : - Ast_411.Parsetree.core_type -> Ast_410.Parsetree.core_type = - fun - { Ast_411.Parsetree.ptyp_desc = ptyp_desc; - Ast_411.Parsetree.ptyp_loc = ptyp_loc; - Ast_411.Parsetree.ptyp_loc_stack = ptyp_loc_stack; - Ast_411.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - Ast_410.Parsetree.ptyp_desc = (copy_core_type_desc ptyp_desc); - Ast_410.Parsetree.ptyp_loc = (copy_location ptyp_loc); - Ast_410.Parsetree.ptyp_loc_stack = (copy_location_stack ptyp_loc_stack); - Ast_410.Parsetree.ptyp_attributes = (copy_attributes ptyp_attributes) - } -and copy_typ x = copy_core_type x -and copy_location_stack : - Ast_411.Parsetree.location_stack -> Ast_410.Parsetree.location_stack = - fun x -> List.map copy_location x -and copy_core_type_desc : - Ast_411.Parsetree.core_type_desc -> Ast_410.Parsetree.core_type_desc = - function - | Ast_411.Parsetree.Ptyp_any -> Ast_410.Parsetree.Ptyp_any - | Ast_411.Parsetree.Ptyp_var x0 -> Ast_410.Parsetree.Ptyp_var x0 - | Ast_411.Parsetree.Ptyp_arrow (x0, x1, x2) -> - Ast_410.Parsetree.Ptyp_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_core_type x2)) - | Ast_411.Parsetree.Ptyp_tuple x0 -> - Ast_410.Parsetree.Ptyp_tuple (List.map copy_core_type x0) - | Ast_411.Parsetree.Ptyp_constr (x0, x1) -> - Ast_410.Parsetree.Ptyp_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_411.Parsetree.Ptyp_object (x0, x1) -> - Ast_410.Parsetree.Ptyp_object - ((List.map copy_object_field x0), (copy_closed_flag x1)) - | Ast_411.Parsetree.Ptyp_class (x0, x1) -> - Ast_410.Parsetree.Ptyp_class - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_411.Parsetree.Ptyp_alias (x0, x1) -> - Ast_410.Parsetree.Ptyp_alias ((copy_core_type x0), x1) - | Ast_411.Parsetree.Ptyp_variant (x0, x1, x2) -> - Ast_410.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), (copy_closed_flag x1), - (Option.map (fun x -> List.map copy_label x) x2)) - | Ast_411.Parsetree.Ptyp_poly (x0, x1) -> - Ast_410.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | Ast_411.Parsetree.Ptyp_package x0 -> - Ast_410.Parsetree.Ptyp_package (copy_package_type x0) - | Ast_411.Parsetree.Ptyp_extension x0 -> - Ast_410.Parsetree.Ptyp_extension (copy_extension x0) -and copy_package_type : - Ast_411.Parsetree.package_type -> Ast_410.Parsetree.package_type = - fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_core_type x1))) x1)) -and copy_row_field : - Ast_411.Parsetree.row_field -> Ast_410.Parsetree.row_field = - fun - { Ast_411.Parsetree.prf_desc = prf_desc; - Ast_411.Parsetree.prf_loc = prf_loc; - Ast_411.Parsetree.prf_attributes = prf_attributes } - -> - { - Ast_410.Parsetree.prf_desc = (copy_row_field_desc prf_desc); - Ast_410.Parsetree.prf_loc = (copy_location prf_loc); - Ast_410.Parsetree.prf_attributes = (copy_attributes prf_attributes) - } -and copy_row_field_desc : - Ast_411.Parsetree.row_field_desc -> Ast_410.Parsetree.row_field_desc = - function - | Ast_411.Parsetree.Rtag (x0, x1, x2) -> - Ast_410.Parsetree.Rtag - ((copy_loc copy_label x0), x1, (List.map copy_core_type x2)) - | Ast_411.Parsetree.Rinherit x0 -> - Ast_410.Parsetree.Rinherit (copy_core_type x0) -and copy_object_field : - Ast_411.Parsetree.object_field -> Ast_410.Parsetree.object_field = - fun - { Ast_411.Parsetree.pof_desc = pof_desc; - Ast_411.Parsetree.pof_loc = pof_loc; - Ast_411.Parsetree.pof_attributes = pof_attributes } - -> - { - Ast_410.Parsetree.pof_desc = (copy_object_field_desc pof_desc); - Ast_410.Parsetree.pof_loc = (copy_location pof_loc); - Ast_410.Parsetree.pof_attributes = (copy_attributes pof_attributes) - } -and copy_attributes : - Ast_411.Parsetree.attributes -> Ast_410.Parsetree.attributes = - fun x -> List.map copy_attribute x -and copy_attribute : - Ast_411.Parsetree.attribute -> Ast_410.Parsetree.attribute = - fun - { Ast_411.Parsetree.attr_name = attr_name; - Ast_411.Parsetree.attr_payload = attr_payload; - Ast_411.Parsetree.attr_loc = attr_loc } - -> - { - Ast_410.Parsetree.attr_name = (copy_loc (fun x -> x) attr_name); - Ast_410.Parsetree.attr_payload = (copy_payload attr_payload); - Ast_410.Parsetree.attr_loc = (copy_location attr_loc) - } -and copy_payload : Ast_411.Parsetree.payload -> Ast_410.Parsetree.payload = - function - | Ast_411.Parsetree.PStr x0 -> Ast_410.Parsetree.PStr (copy_structure x0) - | Ast_411.Parsetree.PSig x0 -> Ast_410.Parsetree.PSig (copy_signature x0) - | Ast_411.Parsetree.PTyp x0 -> Ast_410.Parsetree.PTyp (copy_core_type x0) - | Ast_411.Parsetree.PPat (x0, x1) -> - Ast_410.Parsetree.PPat - ((copy_pattern x0), (Option.map copy_expression x1)) -and copy_structure : - Ast_411.Parsetree.structure -> Ast_410.Parsetree.structure = - fun x -> List.map copy_structure_item x -and copy_structure_item : - Ast_411.Parsetree.structure_item -> Ast_410.Parsetree.structure_item = - fun - { Ast_411.Parsetree.pstr_desc = pstr_desc; - Ast_411.Parsetree.pstr_loc = pstr_loc } - -> - { - Ast_410.Parsetree.pstr_desc = (copy_structure_item_desc pstr_desc); - Ast_410.Parsetree.pstr_loc = (copy_location pstr_loc) - } -and copy_structure_item_desc : - Ast_411.Parsetree.structure_item_desc -> - Ast_410.Parsetree.structure_item_desc - = - function - | Ast_411.Parsetree.Pstr_eval (x0, x1) -> - Ast_410.Parsetree.Pstr_eval - ((copy_expression x0), (copy_attributes x1)) - | Ast_411.Parsetree.Pstr_value (x0, x1) -> - Ast_410.Parsetree.Pstr_value - ((copy_rec_flag x0), (List.map copy_value_binding x1)) - | Ast_411.Parsetree.Pstr_primitive x0 -> - Ast_410.Parsetree.Pstr_primitive (copy_value_description x0) - | Ast_411.Parsetree.Pstr_type (x0, x1) -> - Ast_410.Parsetree.Pstr_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_411.Parsetree.Pstr_typext x0 -> - Ast_410.Parsetree.Pstr_typext (copy_type_extension x0) - | Ast_411.Parsetree.Pstr_exception x0 -> - Ast_410.Parsetree.Pstr_exception (copy_type_exception x0) - | Ast_411.Parsetree.Pstr_module x0 -> - Ast_410.Parsetree.Pstr_module (copy_module_binding x0) - | Ast_411.Parsetree.Pstr_recmodule x0 -> - Ast_410.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) - | Ast_411.Parsetree.Pstr_modtype x0 -> - Ast_410.Parsetree.Pstr_modtype (copy_module_type_declaration x0) - | Ast_411.Parsetree.Pstr_open x0 -> - Ast_410.Parsetree.Pstr_open (copy_open_declaration x0) - | Ast_411.Parsetree.Pstr_class x0 -> - Ast_410.Parsetree.Pstr_class (List.map copy_class_declaration x0) - | Ast_411.Parsetree.Pstr_class_type x0 -> - Ast_410.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | Ast_411.Parsetree.Pstr_include x0 -> - Ast_410.Parsetree.Pstr_include (copy_include_declaration x0) - | Ast_411.Parsetree.Pstr_attribute x0 -> - Ast_410.Parsetree.Pstr_attribute (copy_attribute x0) - | Ast_411.Parsetree.Pstr_extension (x0, x1) -> - Ast_410.Parsetree.Pstr_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_include_declaration : - Ast_411.Parsetree.include_declaration -> - Ast_410.Parsetree.include_declaration - = fun x -> copy_include_infos copy_module_expr x -and copy_class_declaration : - Ast_411.Parsetree.class_declaration -> Ast_410.Parsetree.class_declaration - = fun x -> copy_class_infos copy_class_expr x -and copy_class_expr : - Ast_411.Parsetree.class_expr -> Ast_410.Parsetree.class_expr = - fun - { Ast_411.Parsetree.pcl_desc = pcl_desc; - Ast_411.Parsetree.pcl_loc = pcl_loc; - Ast_411.Parsetree.pcl_attributes = pcl_attributes } - -> - { - Ast_410.Parsetree.pcl_desc = (copy_class_expr_desc pcl_desc); - Ast_410.Parsetree.pcl_loc = (copy_location pcl_loc); - Ast_410.Parsetree.pcl_attributes = (copy_attributes pcl_attributes) - } -and copy_class_expr_desc : - Ast_411.Parsetree.class_expr_desc -> Ast_410.Parsetree.class_expr_desc = - function - | Ast_411.Parsetree.Pcl_constr (x0, x1) -> - Ast_410.Parsetree.Pcl_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_411.Parsetree.Pcl_structure x0 -> - Ast_410.Parsetree.Pcl_structure (copy_class_structure x0) - | Ast_411.Parsetree.Pcl_fun (x0, x1, x2, x3) -> - Ast_410.Parsetree.Pcl_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_class_expr x3)) - | Ast_411.Parsetree.Pcl_apply (x0, x1) -> - Ast_410.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_411.Parsetree.Pcl_let (x0, x1, x2) -> - Ast_410.Parsetree.Pcl_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_class_expr x2)) - | Ast_411.Parsetree.Pcl_constraint (x0, x1) -> - Ast_410.Parsetree.Pcl_constraint - ((copy_class_expr x0), (copy_class_type x1)) - | Ast_411.Parsetree.Pcl_extension x0 -> - Ast_410.Parsetree.Pcl_extension (copy_extension x0) - | Ast_411.Parsetree.Pcl_open (x0, x1) -> - Ast_410.Parsetree.Pcl_open - ((copy_open_description x0), (copy_class_expr x1)) -and copy_class_structure : - Ast_411.Parsetree.class_structure -> Ast_410.Parsetree.class_structure = - fun - { Ast_411.Parsetree.pcstr_self = pcstr_self; - Ast_411.Parsetree.pcstr_fields = pcstr_fields } - -> - { - Ast_410.Parsetree.pcstr_self = (copy_pattern pcstr_self); - Ast_410.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } -and copy_class_field : - Ast_411.Parsetree.class_field -> Ast_410.Parsetree.class_field = - fun - { Ast_411.Parsetree.pcf_desc = pcf_desc; - Ast_411.Parsetree.pcf_loc = pcf_loc; - Ast_411.Parsetree.pcf_attributes = pcf_attributes } - -> - { - Ast_410.Parsetree.pcf_desc = (copy_class_field_desc pcf_desc); - Ast_410.Parsetree.pcf_loc = (copy_location pcf_loc); - Ast_410.Parsetree.pcf_attributes = (copy_attributes pcf_attributes) - } -and copy_class_field_desc : - Ast_411.Parsetree.class_field_desc -> Ast_410.Parsetree.class_field_desc = - function - | Ast_411.Parsetree.Pcf_inherit (x0, x1, x2) -> - Ast_410.Parsetree.Pcf_inherit - ((copy_override_flag x0), (copy_class_expr x1), - (Option.map (fun x -> copy_loc (fun x -> x) x) x2)) - | Ast_411.Parsetree.Pcf_val x0 -> - Ast_410.Parsetree.Pcf_val - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | Ast_411.Parsetree.Pcf_method x0 -> - Ast_410.Parsetree.Pcf_method - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_class_field_kind x2))) - | Ast_411.Parsetree.Pcf_constraint x0 -> - Ast_410.Parsetree.Pcf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_411.Parsetree.Pcf_initializer x0 -> - Ast_410.Parsetree.Pcf_initializer (copy_expression x0) - | Ast_411.Parsetree.Pcf_attribute x0 -> - Ast_410.Parsetree.Pcf_attribute (copy_attribute x0) - | Ast_411.Parsetree.Pcf_extension x0 -> - Ast_410.Parsetree.Pcf_extension (copy_extension x0) -and copy_class_field_kind : - Ast_411.Parsetree.class_field_kind -> Ast_410.Parsetree.class_field_kind = - function - | Ast_411.Parsetree.Cfk_virtual x0 -> - Ast_410.Parsetree.Cfk_virtual (copy_core_type x0) - | Ast_411.Parsetree.Cfk_concrete (x0, x1) -> - Ast_410.Parsetree.Cfk_concrete - ((copy_override_flag x0), (copy_expression x1)) -and copy_open_declaration : - Ast_411.Parsetree.open_declaration -> Ast_410.Parsetree.open_declaration = - fun x -> copy_open_infos copy_module_expr x -and copy_module_binding : - Ast_411.Parsetree.module_binding -> Ast_410.Parsetree.module_binding = - fun - { Ast_411.Parsetree.pmb_name = pmb_name; - Ast_411.Parsetree.pmb_expr = pmb_expr; - Ast_411.Parsetree.pmb_attributes = pmb_attributes; - Ast_411.Parsetree.pmb_loc = pmb_loc } - -> - { - Ast_410.Parsetree.pmb_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name); - Ast_410.Parsetree.pmb_expr = (copy_module_expr pmb_expr); - Ast_410.Parsetree.pmb_attributes = (copy_attributes pmb_attributes); - Ast_410.Parsetree.pmb_loc = (copy_location pmb_loc) - } -and copy_module_expr : - Ast_411.Parsetree.module_expr -> Ast_410.Parsetree.module_expr = - fun - { Ast_411.Parsetree.pmod_desc = pmod_desc; - Ast_411.Parsetree.pmod_loc = pmod_loc; - Ast_411.Parsetree.pmod_attributes = pmod_attributes } - -> - { - Ast_410.Parsetree.pmod_desc = (copy_module_expr_desc pmod_desc); - Ast_410.Parsetree.pmod_loc = (copy_location pmod_loc); - Ast_410.Parsetree.pmod_attributes = (copy_attributes pmod_attributes) - } -and copy_module_expr_desc : - Ast_411.Parsetree.module_expr_desc -> Ast_410.Parsetree.module_expr_desc = - function - | Ast_411.Parsetree.Pmod_ident x0 -> - Ast_410.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) - | Ast_411.Parsetree.Pmod_structure x0 -> - Ast_410.Parsetree.Pmod_structure (copy_structure x0) - | Ast_411.Parsetree.Pmod_functor (x0, x1) -> - Ast_410.Parsetree.Pmod_functor - ((copy_functor_parameter x0), (copy_module_expr x1)) - | Ast_411.Parsetree.Pmod_apply (x0, x1) -> - Ast_410.Parsetree.Pmod_apply - ((copy_module_expr x0), (copy_module_expr x1)) - | Ast_411.Parsetree.Pmod_constraint (x0, x1) -> - Ast_410.Parsetree.Pmod_constraint - ((copy_module_expr x0), (copy_module_type x1)) - | Ast_411.Parsetree.Pmod_unpack x0 -> - Ast_410.Parsetree.Pmod_unpack (copy_expression x0) - | Ast_411.Parsetree.Pmod_extension x0 -> - Ast_410.Parsetree.Pmod_extension (copy_extension x0) -and copy_functor_parameter : - Ast_411.Parsetree.functor_parameter -> Ast_410.Parsetree.functor_parameter - = - function - | Ast_411.Parsetree.Unit -> Ast_410.Parsetree.Unit - | Ast_411.Parsetree.Named (x0, x1) -> - Ast_410.Parsetree.Named - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_type x1)) -and copy_module_type : - Ast_411.Parsetree.module_type -> Ast_410.Parsetree.module_type = - fun - { Ast_411.Parsetree.pmty_desc = pmty_desc; - Ast_411.Parsetree.pmty_loc = pmty_loc; - Ast_411.Parsetree.pmty_attributes = pmty_attributes } - -> - { - Ast_410.Parsetree.pmty_desc = (copy_module_type_desc pmty_desc); - Ast_410.Parsetree.pmty_loc = (copy_location pmty_loc); - Ast_410.Parsetree.pmty_attributes = (copy_attributes pmty_attributes) - } -and copy_module_type_desc : - Ast_411.Parsetree.module_type_desc -> Ast_410.Parsetree.module_type_desc = - function - | Ast_411.Parsetree.Pmty_ident x0 -> - Ast_410.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) - | Ast_411.Parsetree.Pmty_signature x0 -> - Ast_410.Parsetree.Pmty_signature (copy_signature x0) - | Ast_411.Parsetree.Pmty_functor (x0, x1) -> - Ast_410.Parsetree.Pmty_functor - ((copy_functor_parameter x0), (copy_module_type x1)) - | Ast_411.Parsetree.Pmty_with (x0, x1) -> - Ast_410.Parsetree.Pmty_with - ((copy_module_type x0), (List.map copy_with_constraint x1)) - | Ast_411.Parsetree.Pmty_typeof x0 -> - Ast_410.Parsetree.Pmty_typeof (copy_module_expr x0) - | Ast_411.Parsetree.Pmty_extension x0 -> - Ast_410.Parsetree.Pmty_extension (copy_extension x0) - | Ast_411.Parsetree.Pmty_alias x0 -> - Ast_410.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) -and copy_with_constraint : - Ast_411.Parsetree.with_constraint -> Ast_410.Parsetree.with_constraint = - function - | Ast_411.Parsetree.Pwith_type (x0, x1) -> - Ast_410.Parsetree.Pwith_type - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_411.Parsetree.Pwith_module (x0, x1) -> - Ast_410.Parsetree.Pwith_module - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) - | Ast_411.Parsetree.Pwith_typesubst (x0, x1) -> - Ast_410.Parsetree.Pwith_typesubst - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_411.Parsetree.Pwith_modsubst (x0, x1) -> - Ast_410.Parsetree.Pwith_modsubst - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) -and copy_signature : - Ast_411.Parsetree.signature -> Ast_410.Parsetree.signature = - fun x -> List.map copy_signature_item x -and copy_signature_item : - Ast_411.Parsetree.signature_item -> Ast_410.Parsetree.signature_item = - fun - { Ast_411.Parsetree.psig_desc = psig_desc; - Ast_411.Parsetree.psig_loc = psig_loc } - -> - { - Ast_410.Parsetree.psig_desc = (copy_signature_item_desc psig_desc); - Ast_410.Parsetree.psig_loc = (copy_location psig_loc) - } -and copy_signature_item_desc : - Ast_411.Parsetree.signature_item_desc -> - Ast_410.Parsetree.signature_item_desc - = - function - | Ast_411.Parsetree.Psig_value x0 -> - Ast_410.Parsetree.Psig_value (copy_value_description x0) - | Ast_411.Parsetree.Psig_type (x0, x1) -> - Ast_410.Parsetree.Psig_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_411.Parsetree.Psig_typesubst x0 -> - Ast_410.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) - | Ast_411.Parsetree.Psig_typext x0 -> - Ast_410.Parsetree.Psig_typext (copy_type_extension x0) - | Ast_411.Parsetree.Psig_exception x0 -> - Ast_410.Parsetree.Psig_exception (copy_type_exception x0) - | Ast_411.Parsetree.Psig_module x0 -> - Ast_410.Parsetree.Psig_module (copy_module_declaration x0) - | Ast_411.Parsetree.Psig_modsubst x0 -> - Ast_410.Parsetree.Psig_modsubst (copy_module_substitution x0) - | Ast_411.Parsetree.Psig_recmodule x0 -> - Ast_410.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) - | Ast_411.Parsetree.Psig_modtype x0 -> - Ast_410.Parsetree.Psig_modtype (copy_module_type_declaration x0) - | Ast_411.Parsetree.Psig_open x0 -> - Ast_410.Parsetree.Psig_open (copy_open_description x0) - | Ast_411.Parsetree.Psig_include x0 -> - Ast_410.Parsetree.Psig_include (copy_include_description x0) - | Ast_411.Parsetree.Psig_class x0 -> - Ast_410.Parsetree.Psig_class (List.map copy_class_description x0) - | Ast_411.Parsetree.Psig_class_type x0 -> - Ast_410.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | Ast_411.Parsetree.Psig_attribute x0 -> - Ast_410.Parsetree.Psig_attribute (copy_attribute x0) - | Ast_411.Parsetree.Psig_extension (x0, x1) -> - Ast_410.Parsetree.Psig_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_class_type_declaration : - Ast_411.Parsetree.class_type_declaration -> - Ast_410.Parsetree.class_type_declaration - = fun x -> copy_class_infos copy_class_type x -and copy_class_description : - Ast_411.Parsetree.class_description -> Ast_410.Parsetree.class_description - = fun x -> copy_class_infos copy_class_type x -and copy_class_type : - Ast_411.Parsetree.class_type -> Ast_410.Parsetree.class_type = - fun - { Ast_411.Parsetree.pcty_desc = pcty_desc; - Ast_411.Parsetree.pcty_loc = pcty_loc; - Ast_411.Parsetree.pcty_attributes = pcty_attributes } - -> - { - Ast_410.Parsetree.pcty_desc = (copy_class_type_desc pcty_desc); - Ast_410.Parsetree.pcty_loc = (copy_location pcty_loc); - Ast_410.Parsetree.pcty_attributes = (copy_attributes pcty_attributes) - } -and copy_class_type_desc : - Ast_411.Parsetree.class_type_desc -> Ast_410.Parsetree.class_type_desc = - function - | Ast_411.Parsetree.Pcty_constr (x0, x1) -> - Ast_410.Parsetree.Pcty_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_411.Parsetree.Pcty_signature x0 -> - Ast_410.Parsetree.Pcty_signature (copy_class_signature x0) - | Ast_411.Parsetree.Pcty_arrow (x0, x1, x2) -> - Ast_410.Parsetree.Pcty_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_class_type x2)) - | Ast_411.Parsetree.Pcty_extension x0 -> - Ast_410.Parsetree.Pcty_extension (copy_extension x0) - | Ast_411.Parsetree.Pcty_open (x0, x1) -> - Ast_410.Parsetree.Pcty_open - ((copy_open_description x0), (copy_class_type x1)) -and copy_class_signature : - Ast_411.Parsetree.class_signature -> Ast_410.Parsetree.class_signature = - fun - { Ast_411.Parsetree.pcsig_self = pcsig_self; - Ast_411.Parsetree.pcsig_fields = pcsig_fields } - -> - { - Ast_410.Parsetree.pcsig_self = (copy_core_type pcsig_self); - Ast_410.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } -and copy_class_type_field : - Ast_411.Parsetree.class_type_field -> Ast_410.Parsetree.class_type_field = - fun - { Ast_411.Parsetree.pctf_desc = pctf_desc; - Ast_411.Parsetree.pctf_loc = pctf_loc; - Ast_411.Parsetree.pctf_attributes = pctf_attributes } - -> - { - Ast_410.Parsetree.pctf_desc = (copy_class_type_field_desc pctf_desc); - Ast_410.Parsetree.pctf_loc = (copy_location pctf_loc); - Ast_410.Parsetree.pctf_attributes = (copy_attributes pctf_attributes) - } -and copy_class_type_field_desc : - Ast_411.Parsetree.class_type_field_desc -> - Ast_410.Parsetree.class_type_field_desc - = - function - | Ast_411.Parsetree.Pctf_inherit x0 -> - Ast_410.Parsetree.Pctf_inherit (copy_class_type x0) - | Ast_411.Parsetree.Pctf_val x0 -> - Ast_410.Parsetree.Pctf_val - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_411.Parsetree.Pctf_method x0 -> - Ast_410.Parsetree.Pctf_method - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_411.Parsetree.Pctf_constraint x0 -> - Ast_410.Parsetree.Pctf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_411.Parsetree.Pctf_attribute x0 -> - Ast_410.Parsetree.Pctf_attribute (copy_attribute x0) - | Ast_411.Parsetree.Pctf_extension x0 -> - Ast_410.Parsetree.Pctf_extension (copy_extension x0) -and copy_extension : - Ast_411.Parsetree.extension -> Ast_410.Parsetree.extension = - fun x -> - let (x0, x1) = x in ((copy_loc (fun x -> x) x0), (copy_payload x1)) -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_411.Parsetree.class_infos -> 'g0 Ast_410.Parsetree.class_infos - = - fun f0 -> - fun - { Ast_411.Parsetree.pci_virt = pci_virt; - Ast_411.Parsetree.pci_params = pci_params; - Ast_411.Parsetree.pci_name = pci_name; - Ast_411.Parsetree.pci_expr = pci_expr; - Ast_411.Parsetree.pci_loc = pci_loc; - Ast_411.Parsetree.pci_attributes = pci_attributes } - -> - { - Ast_410.Parsetree.pci_virt = (copy_virtual_flag pci_virt); - Ast_410.Parsetree.pci_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - pci_params); - Ast_410.Parsetree.pci_name = (copy_loc (fun x -> x) pci_name); - Ast_410.Parsetree.pci_expr = (f0 pci_expr); - Ast_410.Parsetree.pci_loc = (copy_location pci_loc); - Ast_410.Parsetree.pci_attributes = (copy_attributes pci_attributes) - } -and copy_virtual_flag : - Ast_411.Asttypes.virtual_flag -> Ast_410.Asttypes.virtual_flag = - function - | Ast_411.Asttypes.Virtual -> Ast_410.Asttypes.Virtual - | Ast_411.Asttypes.Concrete -> Ast_410.Asttypes.Concrete -and copy_include_description : - Ast_411.Parsetree.include_description -> - Ast_410.Parsetree.include_description - = fun x -> copy_include_infos copy_module_type x -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_411.Parsetree.include_infos -> - 'g0 Ast_410.Parsetree.include_infos - = - fun f0 -> - fun - { Ast_411.Parsetree.pincl_mod = pincl_mod; - Ast_411.Parsetree.pincl_loc = pincl_loc; - Ast_411.Parsetree.pincl_attributes = pincl_attributes } - -> - { - Ast_410.Parsetree.pincl_mod = (f0 pincl_mod); - Ast_410.Parsetree.pincl_loc = (copy_location pincl_loc); - Ast_410.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } -and copy_open_description : - Ast_411.Parsetree.open_description -> Ast_410.Parsetree.open_description = - fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x -and copy_open_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_411.Parsetree.open_infos -> 'g0 Ast_410.Parsetree.open_infos - = - fun f0 -> - fun - { Ast_411.Parsetree.popen_expr = popen_expr; - Ast_411.Parsetree.popen_override = popen_override; - Ast_411.Parsetree.popen_loc = popen_loc; - Ast_411.Parsetree.popen_attributes = popen_attributes } - -> - { - Ast_410.Parsetree.popen_expr = (f0 popen_expr); - Ast_410.Parsetree.popen_override = - (copy_override_flag popen_override); - Ast_410.Parsetree.popen_loc = (copy_location popen_loc); - Ast_410.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } -and copy_override_flag : - Ast_411.Asttypes.override_flag -> Ast_410.Asttypes.override_flag = - function - | Ast_411.Asttypes.Override -> Ast_410.Asttypes.Override - | Ast_411.Asttypes.Fresh -> Ast_410.Asttypes.Fresh -and copy_module_type_declaration : - Ast_411.Parsetree.module_type_declaration -> - Ast_410.Parsetree.module_type_declaration - = - fun - { Ast_411.Parsetree.pmtd_name = pmtd_name; - Ast_411.Parsetree.pmtd_type = pmtd_type; - Ast_411.Parsetree.pmtd_attributes = pmtd_attributes; - Ast_411.Parsetree.pmtd_loc = pmtd_loc } - -> - { - Ast_410.Parsetree.pmtd_name = (copy_loc (fun x -> x) pmtd_name); - Ast_410.Parsetree.pmtd_type = (Option.map copy_module_type pmtd_type); - Ast_410.Parsetree.pmtd_attributes = (copy_attributes pmtd_attributes); - Ast_410.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } -and copy_module_substitution : - Ast_411.Parsetree.module_substitution -> - Ast_410.Parsetree.module_substitution - = - fun - { Ast_411.Parsetree.pms_name = pms_name; - Ast_411.Parsetree.pms_manifest = pms_manifest; - Ast_411.Parsetree.pms_attributes = pms_attributes; - Ast_411.Parsetree.pms_loc = pms_loc } - -> - { - Ast_410.Parsetree.pms_name = (copy_loc (fun x -> x) pms_name); - Ast_410.Parsetree.pms_manifest = - (copy_loc copy_Longident_t pms_manifest); - Ast_410.Parsetree.pms_attributes = (copy_attributes pms_attributes); - Ast_410.Parsetree.pms_loc = (copy_location pms_loc) - } -and copy_module_declaration : - Ast_411.Parsetree.module_declaration -> - Ast_410.Parsetree.module_declaration - = - fun - { Ast_411.Parsetree.pmd_name = pmd_name; - Ast_411.Parsetree.pmd_type = pmd_type; - Ast_411.Parsetree.pmd_attributes = pmd_attributes; - Ast_411.Parsetree.pmd_loc = pmd_loc } - -> - { - Ast_410.Parsetree.pmd_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name); - Ast_410.Parsetree.pmd_type = (copy_module_type pmd_type); - Ast_410.Parsetree.pmd_attributes = (copy_attributes pmd_attributes); - Ast_410.Parsetree.pmd_loc = (copy_location pmd_loc) - } -and copy_type_exception : - Ast_411.Parsetree.type_exception -> Ast_410.Parsetree.type_exception = - fun - { Ast_411.Parsetree.ptyexn_constructor = ptyexn_constructor; - Ast_411.Parsetree.ptyexn_loc = ptyexn_loc; - Ast_411.Parsetree.ptyexn_attributes = ptyexn_attributes } - -> - { - Ast_410.Parsetree.ptyexn_constructor = - (copy_extension_constructor ptyexn_constructor); - Ast_410.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); - Ast_410.Parsetree.ptyexn_attributes = - (copy_attributes ptyexn_attributes) - } -and copy_type_extension : - Ast_411.Parsetree.type_extension -> Ast_410.Parsetree.type_extension = - fun - { Ast_411.Parsetree.ptyext_path = ptyext_path; - Ast_411.Parsetree.ptyext_params = ptyext_params; - Ast_411.Parsetree.ptyext_constructors = ptyext_constructors; - Ast_411.Parsetree.ptyext_private = ptyext_private; - Ast_411.Parsetree.ptyext_loc = ptyext_loc; - Ast_411.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - Ast_410.Parsetree.ptyext_path = (copy_loc copy_Longident_t ptyext_path); - Ast_410.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - ptyext_params); - Ast_410.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor ptyext_constructors); - Ast_410.Parsetree.ptyext_private = (copy_private_flag ptyext_private); - Ast_410.Parsetree.ptyext_loc = (copy_location ptyext_loc); - Ast_410.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } -and copy_extension_constructor : - Ast_411.Parsetree.extension_constructor -> - Ast_410.Parsetree.extension_constructor - = - fun - { Ast_411.Parsetree.pext_name = pext_name; - Ast_411.Parsetree.pext_kind = pext_kind; - Ast_411.Parsetree.pext_loc = pext_loc; - Ast_411.Parsetree.pext_attributes = pext_attributes } - -> - { - Ast_410.Parsetree.pext_name = (copy_loc (fun x -> x) pext_name); - Ast_410.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - Ast_410.Parsetree.pext_loc = (copy_location pext_loc); - Ast_410.Parsetree.pext_attributes = (copy_attributes pext_attributes) - } -and copy_extension_constructor_kind : - Ast_411.Parsetree.extension_constructor_kind -> - Ast_410.Parsetree.extension_constructor_kind - = - function - | Ast_411.Parsetree.Pext_decl (x0, x1) -> - Ast_410.Parsetree.Pext_decl - ((copy_constructor_arguments x0), (Option.map copy_core_type x1)) - | Ast_411.Parsetree.Pext_rebind x0 -> - Ast_410.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) -and copy_type_declaration : - Ast_411.Parsetree.type_declaration -> Ast_410.Parsetree.type_declaration = - fun - { Ast_411.Parsetree.ptype_name = ptype_name; - Ast_411.Parsetree.ptype_params = ptype_params; - Ast_411.Parsetree.ptype_cstrs = ptype_cstrs; - Ast_411.Parsetree.ptype_kind = ptype_kind; - Ast_411.Parsetree.ptype_private = ptype_private; - Ast_411.Parsetree.ptype_manifest = ptype_manifest; - Ast_411.Parsetree.ptype_attributes = ptype_attributes; - Ast_411.Parsetree.ptype_loc = ptype_loc } - -> - { - Ast_410.Parsetree.ptype_name = (copy_loc (fun x -> x) ptype_name); - Ast_410.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0, x1) = x in ((copy_core_type x0), (copy_variance x1))) - ptype_params); - Ast_410.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0, x1, x2) = x in - ((copy_core_type x0), (copy_core_type x1), (copy_location x2))) - ptype_cstrs); - Ast_410.Parsetree.ptype_kind = (copy_type_kind ptype_kind); - Ast_410.Parsetree.ptype_private = (copy_private_flag ptype_private); - Ast_410.Parsetree.ptype_manifest = - (Option.map copy_core_type ptype_manifest); - Ast_410.Parsetree.ptype_attributes = (copy_attributes ptype_attributes); - Ast_410.Parsetree.ptype_loc = (copy_location ptype_loc) - } -and copy_private_flag : - Ast_411.Asttypes.private_flag -> Ast_410.Asttypes.private_flag = - function - | Ast_411.Asttypes.Private -> Ast_410.Asttypes.Private - | Ast_411.Asttypes.Public -> Ast_410.Asttypes.Public -and copy_type_kind : - Ast_411.Parsetree.type_kind -> Ast_410.Parsetree.type_kind = - function - | Ast_411.Parsetree.Ptype_abstract -> Ast_410.Parsetree.Ptype_abstract - | Ast_411.Parsetree.Ptype_variant x0 -> - Ast_410.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | Ast_411.Parsetree.Ptype_record x0 -> - Ast_410.Parsetree.Ptype_record (List.map copy_label_declaration x0) - | Ast_411.Parsetree.Ptype_open -> Ast_410.Parsetree.Ptype_open -and copy_constructor_declaration : - Ast_411.Parsetree.constructor_declaration -> - Ast_410.Parsetree.constructor_declaration - = - fun - { Ast_411.Parsetree.pcd_name = pcd_name; - Ast_411.Parsetree.pcd_args = pcd_args; - Ast_411.Parsetree.pcd_res = pcd_res; - Ast_411.Parsetree.pcd_loc = pcd_loc; - Ast_411.Parsetree.pcd_attributes = pcd_attributes } - -> - { - Ast_410.Parsetree.pcd_name = (copy_loc (fun x -> x) pcd_name); - Ast_410.Parsetree.pcd_args = (copy_constructor_arguments pcd_args); - Ast_410.Parsetree.pcd_res = (Option.map copy_core_type pcd_res); - Ast_410.Parsetree.pcd_loc = (copy_location pcd_loc); - Ast_410.Parsetree.pcd_attributes = (copy_attributes pcd_attributes) - } -and copy_constructor_arguments : - Ast_411.Parsetree.constructor_arguments -> - Ast_410.Parsetree.constructor_arguments - = - function - | Ast_411.Parsetree.Pcstr_tuple x0 -> - Ast_410.Parsetree.Pcstr_tuple (List.map copy_core_type x0) - | Ast_411.Parsetree.Pcstr_record x0 -> - Ast_410.Parsetree.Pcstr_record (List.map copy_label_declaration x0) -and copy_label_declaration : - Ast_411.Parsetree.label_declaration -> Ast_410.Parsetree.label_declaration - = - fun - { Ast_411.Parsetree.pld_name = pld_name; - Ast_411.Parsetree.pld_mutable = pld_mutable; - Ast_411.Parsetree.pld_type = pld_type; - Ast_411.Parsetree.pld_loc = pld_loc; - Ast_411.Parsetree.pld_attributes = pld_attributes } - -> - { - Ast_410.Parsetree.pld_name = (copy_loc (fun x -> x) pld_name); - Ast_410.Parsetree.pld_mutable = (copy_mutable_flag pld_mutable); - Ast_410.Parsetree.pld_type = (copy_core_type pld_type); - Ast_410.Parsetree.pld_loc = (copy_location pld_loc); - Ast_410.Parsetree.pld_attributes = (copy_attributes pld_attributes) - } -and copy_mutable_flag : - Ast_411.Asttypes.mutable_flag -> Ast_410.Asttypes.mutable_flag = - function - | Ast_411.Asttypes.Immutable -> Ast_410.Asttypes.Immutable - | Ast_411.Asttypes.Mutable -> Ast_410.Asttypes.Mutable -and copy_variance : Ast_411.Asttypes.variance -> Ast_410.Asttypes.variance = - function - | Ast_411.Asttypes.Covariant -> Ast_410.Asttypes.Covariant - | Ast_411.Asttypes.Contravariant -> Ast_410.Asttypes.Contravariant - | Ast_411.Asttypes.Invariant -> Ast_410.Asttypes.Invariant -and copy_value_description : - Ast_411.Parsetree.value_description -> Ast_410.Parsetree.value_description - = - fun - { Ast_411.Parsetree.pval_name = pval_name; - Ast_411.Parsetree.pval_type = pval_type; - Ast_411.Parsetree.pval_prim = pval_prim; - Ast_411.Parsetree.pval_attributes = pval_attributes; - Ast_411.Parsetree.pval_loc = pval_loc } - -> - { - Ast_410.Parsetree.pval_name = (copy_loc (fun x -> x) pval_name); - Ast_410.Parsetree.pval_type = (copy_core_type pval_type); - Ast_410.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - Ast_410.Parsetree.pval_attributes = (copy_attributes pval_attributes); - Ast_410.Parsetree.pval_loc = (copy_location pval_loc) - } -and copy_object_field_desc : - Ast_411.Parsetree.object_field_desc -> Ast_410.Parsetree.object_field_desc - = - function - | Ast_411.Parsetree.Otag (x0, x1) -> - Ast_410.Parsetree.Otag ((copy_loc copy_label x0), (copy_core_type x1)) - | Ast_411.Parsetree.Oinherit x0 -> - Ast_410.Parsetree.Oinherit (copy_core_type x0) -and copy_arg_label : Ast_411.Asttypes.arg_label -> Ast_410.Asttypes.arg_label - = - function - | Ast_411.Asttypes.Nolabel -> Ast_410.Asttypes.Nolabel - | Ast_411.Asttypes.Labelled x0 -> Ast_410.Asttypes.Labelled x0 - | Ast_411.Asttypes.Optional x0 -> Ast_410.Asttypes.Optional x0 -and copy_closed_flag : - Ast_411.Asttypes.closed_flag -> Ast_410.Asttypes.closed_flag = - function - | Ast_411.Asttypes.Closed -> Ast_410.Asttypes.Closed - | Ast_411.Asttypes.Open -> Ast_410.Asttypes.Open -and copy_label : Ast_411.Asttypes.label -> Ast_410.Asttypes.label = - fun x -> x -and copy_rec_flag : Ast_411.Asttypes.rec_flag -> Ast_410.Asttypes.rec_flag = - function - | Ast_411.Asttypes.Nonrecursive -> Ast_410.Asttypes.Nonrecursive - | Ast_411.Asttypes.Recursive -> Ast_410.Asttypes.Recursive -and copy_constant : Ast_411.Parsetree.constant -> Ast_410.Parsetree.constant - = - function - | Ast_411.Parsetree.Pconst_integer (x0, x1) -> - Ast_410.Parsetree.Pconst_integer (x0, (Option.map (fun x -> x) x1)) - | Ast_411.Parsetree.Pconst_char x0 -> Ast_410.Parsetree.Pconst_char x0 - | Ast_411.Parsetree.Pconst_string (x0, _, x2) -> - Ast_410.Parsetree.Pconst_string - (x0, (Option.map (fun x -> x) x2)) - | Ast_411.Parsetree.Pconst_float (x0, x1) -> - Ast_410.Parsetree.Pconst_float (x0, (Option.map (fun x -> x) x1)) -and copy_Longident_t : Ast_411.Longident.t -> Ast_410.Longident.t = - function - | Ast_411.Longident.Lident x0 -> Ast_410.Longident.Lident x0 - | Ast_411.Longident.Ldot (x0, x1) -> - Ast_410.Longident.Ldot ((copy_Longident_t x0), x1) - | Ast_411.Longident.Lapply (x0, x1) -> - Ast_410.Longident.Lapply ((copy_Longident_t x0), (copy_Longident_t x1)) -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 Ast_411.Asttypes.loc -> 'g0 Ast_410.Asttypes.loc - = - fun f0 -> - fun { Ast_411.Asttypes.txt = txt; Ast_411.Asttypes.loc = loc } -> - { - Ast_410.Asttypes.txt = (f0 txt); - Ast_410.Asttypes.loc = (copy_location loc) - } -and copy_location : Ast_411.Location.t -> Ast_410.Location.t = - fun - { Ast_411.Location.loc_start = loc_start; - Ast_411.Location.loc_end = loc_end; - Ast_411.Location.loc_ghost = loc_ghost } - -> - { - Ast_410.Location.loc_start = (copy_position loc_start); - Ast_410.Location.loc_end = (copy_position loc_end); - Ast_410.Location.loc_ghost = loc_ghost - } -and copy_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum - } diff --git a/src/vendored-omp/src/migrate_parsetree_411_412.ml b/src/vendored-omp/src/migrate_parsetree_411_412.ml index ac90feb51..6472d7081 100644 --- a/src/vendored-omp/src/migrate_parsetree_411_412.ml +++ b/src/vendored-omp/src/migrate_parsetree_411_412.ml @@ -15,129 +15,3 @@ include Migrate_parsetree_411_412_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload"; - "binding_op"; "module_substitution"; "open_declaration"; "type_exception"; - "constant" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - binding_op; - module_substitution; - open_declaration; - type_exception; - constant; - (*$*) - } as mapper) -> - let module Def = Migrate_parsetree_def in - let module R = Migrate_parsetree_412_411_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - binding_op = (fun _ x -> copy_binding_op (binding_op mapper (R.copy_binding_op x))); - module_substitution = (fun _ x -> copy_module_substitution (module_substitution mapper (R.copy_module_substitution x))); - open_declaration = (fun _ x -> copy_open_declaration (open_declaration mapper (R.copy_open_declaration x))); - type_exception = (fun _ x -> copy_type_exception (type_exception mapper (R.copy_type_exception x))); - constant = (fun _ x -> copy_constant (constant mapper (R.copy_constant x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_411_412_migrate.ml b/src/vendored-omp/src/migrate_parsetree_411_412_migrate.ml index fe88a13c8..3bccf76cd 100644 --- a/src/vendored-omp/src/migrate_parsetree_411_412_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_411_412_migrate.ml @@ -37,14 +37,14 @@ and copy_out_phrase : | Ast_411.Outcometree.Ophr_exception x0 -> Ast_412.Outcometree.Ophr_exception (let (x0, x1) = x0 in (x0, (copy_out_value x1))) + and copy_out_type_param : string * (bool * bool) -> Ast_412.Outcometree.out_type_param = function (str, v) -> let v = match v with | (true, false) -> Ast_412.Asttypes.Covariant | (false, true) -> Ast_412.Asttypes.Contravariant - | (false, false) -> Ast_412.Asttypes.NoVariance - | _ -> assert false + | (false, false) | (true, true) -> Ast_412.Asttypes.NoVariance in str, (v, Ast_412.Asttypes.NoInjectivity) @@ -169,6 +169,11 @@ and copy_out_extension_constructor : (Option.map copy_out_type oext_ret_type); Ast_412.Outcometree.oext_private = (copy_private_flag oext_private) } +and copy_private_flag : + Ast_411.Asttypes.private_flag -> Ast_412.Asttypes.private_flag = + function + | Ast_411.Asttypes.Private -> Ast_412.Asttypes.Private + | Ast_411.Asttypes.Public -> Ast_412.Asttypes.Public and copy_out_rec_status : Ast_411.Outcometree.out_rec_status -> Ast_412.Outcometree.out_rec_status = function @@ -320,1209 +325,3 @@ and copy_out_name : Ast_411.Outcometree.out_name -> Ast_412.Outcometree.out_name = fun { Ast_411.Outcometree.printed_name = printed_name } -> { Ast_412.Outcometree.printed_name = printed_name } -and copy_toplevel_phrase : - Ast_411.Parsetree.toplevel_phrase -> Ast_412.Parsetree.toplevel_phrase = - function - | Ast_411.Parsetree.Ptop_def x0 -> - Ast_412.Parsetree.Ptop_def (copy_structure x0) - | Ast_411.Parsetree.Ptop_dir x0 -> - Ast_412.Parsetree.Ptop_dir (copy_toplevel_directive x0) -and copy_toplevel_directive : - Ast_411.Parsetree.toplevel_directive -> - Ast_412.Parsetree.toplevel_directive - = - fun - { Ast_411.Parsetree.pdir_name = pdir_name; - Ast_411.Parsetree.pdir_arg = pdir_arg; - Ast_411.Parsetree.pdir_loc = pdir_loc } - -> - { - Ast_412.Parsetree.pdir_name = (copy_loc (fun x -> x) pdir_name); - Ast_412.Parsetree.pdir_arg = - (Option.map copy_directive_argument pdir_arg); - Ast_412.Parsetree.pdir_loc = (copy_location pdir_loc) - } -and copy_directive_argument : - Ast_411.Parsetree.directive_argument -> - Ast_412.Parsetree.directive_argument - = - fun - { Ast_411.Parsetree.pdira_desc = pdira_desc; - Ast_411.Parsetree.pdira_loc = pdira_loc } - -> - { - Ast_412.Parsetree.pdira_desc = - (copy_directive_argument_desc pdira_desc); - Ast_412.Parsetree.pdira_loc = (copy_location pdira_loc) - } -and copy_directive_argument_desc : - Ast_411.Parsetree.directive_argument_desc -> - Ast_412.Parsetree.directive_argument_desc - = - function - | Ast_411.Parsetree.Pdir_string x0 -> Ast_412.Parsetree.Pdir_string x0 - | Ast_411.Parsetree.Pdir_int (x0, x1) -> - Ast_412.Parsetree.Pdir_int (x0, (Option.map (fun x -> x) x1)) - | Ast_411.Parsetree.Pdir_ident x0 -> - Ast_412.Parsetree.Pdir_ident (copy_Longident_t x0) - | Ast_411.Parsetree.Pdir_bool x0 -> Ast_412.Parsetree.Pdir_bool x0 -and copy_expression : - Ast_411.Parsetree.expression -> Ast_412.Parsetree.expression = - fun - { Ast_411.Parsetree.pexp_desc = pexp_desc; - Ast_411.Parsetree.pexp_loc = pexp_loc; - Ast_411.Parsetree.pexp_loc_stack = pexp_loc_stack; - Ast_411.Parsetree.pexp_attributes = pexp_attributes } - -> - { - Ast_412.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - Ast_412.Parsetree.pexp_loc = (copy_location pexp_loc); - Ast_412.Parsetree.pexp_loc_stack = (copy_location_stack pexp_loc_stack); - Ast_412.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } -and copy_expr x = copy_expression x -and copy_expression_desc : - Ast_411.Parsetree.expression_desc -> Ast_412.Parsetree.expression_desc = - function - | Ast_411.Parsetree.Pexp_ident x0 -> - Ast_412.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) - | Ast_411.Parsetree.Pexp_constant x0 -> - Ast_412.Parsetree.Pexp_constant (copy_constant x0) - | Ast_411.Parsetree.Pexp_let (x0, x1, x2) -> - Ast_412.Parsetree.Pexp_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_expression x2)) - | Ast_411.Parsetree.Pexp_function x0 -> - Ast_412.Parsetree.Pexp_function (List.map copy_case x0) - | Ast_411.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_412.Parsetree.Pexp_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_expression x3)) - | Ast_411.Parsetree.Pexp_apply (x0, x1) -> - Ast_412.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_411.Parsetree.Pexp_match (x0, x1) -> - Ast_412.Parsetree.Pexp_match - ((copy_expression x0), (List.map copy_case x1)) - | Ast_411.Parsetree.Pexp_try (x0, x1) -> - Ast_412.Parsetree.Pexp_try - ((copy_expression x0), (List.map copy_case x1)) - | Ast_411.Parsetree.Pexp_tuple x0 -> - Ast_412.Parsetree.Pexp_tuple (List.map copy_expression x0) - | Ast_411.Parsetree.Pexp_construct (x0, x1) -> - Ast_412.Parsetree.Pexp_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_expression x1)) - | Ast_411.Parsetree.Pexp_variant (x0, x1) -> - Ast_412.Parsetree.Pexp_variant - ((copy_label x0), (Option.map copy_expression x1)) - | Ast_411.Parsetree.Pexp_record (x0, x1) -> - Ast_412.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_expression x1))) x0), - (Option.map copy_expression x1)) - | Ast_411.Parsetree.Pexp_field (x0, x1) -> - Ast_412.Parsetree.Pexp_field - ((copy_expression x0), (copy_loc copy_Longident_t x1)) - | Ast_411.Parsetree.Pexp_setfield (x0, x1, x2) -> - Ast_412.Parsetree.Pexp_setfield - ((copy_expression x0), (copy_loc copy_Longident_t x1), - (copy_expression x2)) - | Ast_411.Parsetree.Pexp_array x0 -> - Ast_412.Parsetree.Pexp_array (List.map copy_expression x0) - | Ast_411.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> - Ast_412.Parsetree.Pexp_ifthenelse - ((copy_expression x0), (copy_expression x1), - (Option.map copy_expression x2)) - | Ast_411.Parsetree.Pexp_sequence (x0, x1) -> - Ast_412.Parsetree.Pexp_sequence - ((copy_expression x0), (copy_expression x1)) - | Ast_411.Parsetree.Pexp_while (x0, x1) -> - Ast_412.Parsetree.Pexp_while - ((copy_expression x0), (copy_expression x1)) - | Ast_411.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> - Ast_412.Parsetree.Pexp_for - ((copy_pattern x0), (copy_expression x1), (copy_expression x2), - (copy_direction_flag x3), (copy_expression x4)) - | Ast_411.Parsetree.Pexp_constraint (x0, x1) -> - Ast_412.Parsetree.Pexp_constraint - ((copy_expression x0), (copy_core_type x1)) - | Ast_411.Parsetree.Pexp_coerce (x0, x1, x2) -> - Ast_412.Parsetree.Pexp_coerce - ((copy_expression x0), (Option.map copy_core_type x1), - (copy_core_type x2)) - | Ast_411.Parsetree.Pexp_send (x0, x1) -> - Ast_412.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc copy_label x1)) - | Ast_411.Parsetree.Pexp_new x0 -> - Ast_412.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) - | Ast_411.Parsetree.Pexp_setinstvar (x0, x1) -> - Ast_412.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), (copy_expression x1)) - | Ast_411.Parsetree.Pexp_override x0 -> - Ast_412.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_label x0), (copy_expression x1))) x0) - | Ast_411.Parsetree.Pexp_letmodule (x0, x1, x2) -> - Ast_412.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_expr x1), (copy_expression x2)) - | Ast_411.Parsetree.Pexp_letexception (x0, x1) -> - Ast_412.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), (copy_expression x1)) - | Ast_411.Parsetree.Pexp_assert x0 -> - Ast_412.Parsetree.Pexp_assert (copy_expression x0) - | Ast_411.Parsetree.Pexp_lazy x0 -> - Ast_412.Parsetree.Pexp_lazy (copy_expression x0) - | Ast_411.Parsetree.Pexp_poly (x0, x1) -> - Ast_412.Parsetree.Pexp_poly - ((copy_expression x0), (Option.map copy_core_type x1)) - | Ast_411.Parsetree.Pexp_object x0 -> - Ast_412.Parsetree.Pexp_object (copy_class_structure x0) - | Ast_411.Parsetree.Pexp_newtype (x0, x1) -> - Ast_412.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | Ast_411.Parsetree.Pexp_pack x0 -> - Ast_412.Parsetree.Pexp_pack (copy_module_expr x0) - | Ast_411.Parsetree.Pexp_open (x0, x1) -> - Ast_412.Parsetree.Pexp_open - ((copy_open_declaration x0), (copy_expression x1)) - | Ast_411.Parsetree.Pexp_letop x0 -> - Ast_412.Parsetree.Pexp_letop (copy_letop x0) - | Ast_411.Parsetree.Pexp_extension x0 -> - Ast_412.Parsetree.Pexp_extension (copy_extension x0) - | Ast_411.Parsetree.Pexp_unreachable -> Ast_412.Parsetree.Pexp_unreachable -and copy_letop : Ast_411.Parsetree.letop -> Ast_412.Parsetree.letop = - fun - { Ast_411.Parsetree.let_ = let_; Ast_411.Parsetree.ands = ands; - Ast_411.Parsetree.body = body } - -> - { - Ast_412.Parsetree.let_ = (copy_binding_op let_); - Ast_412.Parsetree.ands = (List.map copy_binding_op ands); - Ast_412.Parsetree.body = (copy_expression body) - } -and copy_binding_op : - Ast_411.Parsetree.binding_op -> Ast_412.Parsetree.binding_op = - fun - { Ast_411.Parsetree.pbop_op = pbop_op; - Ast_411.Parsetree.pbop_pat = pbop_pat; - Ast_411.Parsetree.pbop_exp = pbop_exp; - Ast_411.Parsetree.pbop_loc = pbop_loc } - -> - { - Ast_412.Parsetree.pbop_op = (copy_loc (fun x -> x) pbop_op); - Ast_412.Parsetree.pbop_pat = (copy_pattern pbop_pat); - Ast_412.Parsetree.pbop_exp = (copy_expression pbop_exp); - Ast_412.Parsetree.pbop_loc = (copy_location pbop_loc) - } -and copy_direction_flag : - Ast_411.Asttypes.direction_flag -> Ast_412.Asttypes.direction_flag = - function - | Ast_411.Asttypes.Upto -> Ast_412.Asttypes.Upto - | Ast_411.Asttypes.Downto -> Ast_412.Asttypes.Downto -and copy_cases : Ast_411.Parsetree.case list -> Ast_412.Parsetree.case list = - fun x -> List.map copy_case x -and copy_case : Ast_411.Parsetree.case -> Ast_412.Parsetree.case = - fun - { Ast_411.Parsetree.pc_lhs = pc_lhs; - Ast_411.Parsetree.pc_guard = pc_guard; - Ast_411.Parsetree.pc_rhs = pc_rhs } - -> - { - Ast_412.Parsetree.pc_lhs = (copy_pattern pc_lhs); - Ast_412.Parsetree.pc_guard = (Option.map copy_expression pc_guard); - Ast_412.Parsetree.pc_rhs = (copy_expression pc_rhs) - } -and copy_value_binding : - Ast_411.Parsetree.value_binding -> Ast_412.Parsetree.value_binding = - fun - { Ast_411.Parsetree.pvb_pat = pvb_pat; - Ast_411.Parsetree.pvb_expr = pvb_expr; - Ast_411.Parsetree.pvb_attributes = pvb_attributes; - Ast_411.Parsetree.pvb_loc = pvb_loc } - -> - { - Ast_412.Parsetree.pvb_pat = (copy_pattern pvb_pat); - Ast_412.Parsetree.pvb_expr = (copy_expression pvb_expr); - Ast_412.Parsetree.pvb_attributes = (copy_attributes pvb_attributes); - Ast_412.Parsetree.pvb_loc = (copy_location pvb_loc) - } -and copy_pattern : Ast_411.Parsetree.pattern -> Ast_412.Parsetree.pattern = - fun - { Ast_411.Parsetree.ppat_desc = ppat_desc; - Ast_411.Parsetree.ppat_loc = ppat_loc; - Ast_411.Parsetree.ppat_loc_stack = ppat_loc_stack; - Ast_411.Parsetree.ppat_attributes = ppat_attributes } - -> - { - Ast_412.Parsetree.ppat_desc = (copy_pattern_desc ppat_desc); - Ast_412.Parsetree.ppat_loc = (copy_location ppat_loc); - Ast_412.Parsetree.ppat_loc_stack = (copy_location_stack ppat_loc_stack); - Ast_412.Parsetree.ppat_attributes = (copy_attributes ppat_attributes) - } -and copy_pat x = copy_pattern x -and copy_pattern_desc : - Ast_411.Parsetree.pattern_desc -> Ast_412.Parsetree.pattern_desc = - function - | Ast_411.Parsetree.Ppat_any -> Ast_412.Parsetree.Ppat_any - | Ast_411.Parsetree.Ppat_var x0 -> - Ast_412.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | Ast_411.Parsetree.Ppat_alias (x0, x1) -> - Ast_412.Parsetree.Ppat_alias - ((copy_pattern x0), (copy_loc (fun x -> x) x1)) - | Ast_411.Parsetree.Ppat_constant x0 -> - Ast_412.Parsetree.Ppat_constant (copy_constant x0) - | Ast_411.Parsetree.Ppat_interval (x0, x1) -> - Ast_412.Parsetree.Ppat_interval - ((copy_constant x0), (copy_constant x1)) - | Ast_411.Parsetree.Ppat_tuple x0 -> - Ast_412.Parsetree.Ppat_tuple (List.map copy_pattern x0) - | Ast_411.Parsetree.Ppat_construct (x0, x1) -> - Ast_412.Parsetree.Ppat_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_pattern x1)) - | Ast_411.Parsetree.Ppat_variant (x0, x1) -> - Ast_412.Parsetree.Ppat_variant - ((copy_label x0), (Option.map copy_pattern x1)) - | Ast_411.Parsetree.Ppat_record (x0, x1) -> - Ast_412.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | Ast_411.Parsetree.Ppat_array x0 -> - Ast_412.Parsetree.Ppat_array (List.map copy_pattern x0) - | Ast_411.Parsetree.Ppat_or (x0, x1) -> - Ast_412.Parsetree.Ppat_or ((copy_pattern x0), (copy_pattern x1)) - | Ast_411.Parsetree.Ppat_constraint (x0, x1) -> - Ast_412.Parsetree.Ppat_constraint - ((copy_pattern x0), (copy_core_type x1)) - | Ast_411.Parsetree.Ppat_type x0 -> - Ast_412.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) - | Ast_411.Parsetree.Ppat_lazy x0 -> - Ast_412.Parsetree.Ppat_lazy (copy_pattern x0) - | Ast_411.Parsetree.Ppat_unpack x0 -> - Ast_412.Parsetree.Ppat_unpack - (copy_loc (fun x -> Option.map (fun x -> x) x) x0) - | Ast_411.Parsetree.Ppat_exception x0 -> - Ast_412.Parsetree.Ppat_exception (copy_pattern x0) - | Ast_411.Parsetree.Ppat_extension x0 -> - Ast_412.Parsetree.Ppat_extension (copy_extension x0) - | Ast_411.Parsetree.Ppat_open (x0, x1) -> - Ast_412.Parsetree.Ppat_open - ((copy_loc copy_Longident_t x0), (copy_pattern x1)) -and copy_core_type : - Ast_411.Parsetree.core_type -> Ast_412.Parsetree.core_type = - fun - { Ast_411.Parsetree.ptyp_desc = ptyp_desc; - Ast_411.Parsetree.ptyp_loc = ptyp_loc; - Ast_411.Parsetree.ptyp_loc_stack = ptyp_loc_stack; - Ast_411.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - Ast_412.Parsetree.ptyp_desc = (copy_core_type_desc ptyp_desc); - Ast_412.Parsetree.ptyp_loc = (copy_location ptyp_loc); - Ast_412.Parsetree.ptyp_loc_stack = (copy_location_stack ptyp_loc_stack); - Ast_412.Parsetree.ptyp_attributes = (copy_attributes ptyp_attributes) - } -and copy_typ x = copy_core_type x -and copy_location_stack : - Ast_411.Parsetree.location_stack -> Ast_412.Parsetree.location_stack = - fun x -> List.map copy_location x -and copy_core_type_desc : - Ast_411.Parsetree.core_type_desc -> Ast_412.Parsetree.core_type_desc = - function - | Ast_411.Parsetree.Ptyp_any -> Ast_412.Parsetree.Ptyp_any - | Ast_411.Parsetree.Ptyp_var x0 -> Ast_412.Parsetree.Ptyp_var x0 - | Ast_411.Parsetree.Ptyp_arrow (x0, x1, x2) -> - Ast_412.Parsetree.Ptyp_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_core_type x2)) - | Ast_411.Parsetree.Ptyp_tuple x0 -> - Ast_412.Parsetree.Ptyp_tuple (List.map copy_core_type x0) - | Ast_411.Parsetree.Ptyp_constr (x0, x1) -> - Ast_412.Parsetree.Ptyp_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_411.Parsetree.Ptyp_object (x0, x1) -> - Ast_412.Parsetree.Ptyp_object - ((List.map copy_object_field x0), (copy_closed_flag x1)) - | Ast_411.Parsetree.Ptyp_class (x0, x1) -> - Ast_412.Parsetree.Ptyp_class - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_411.Parsetree.Ptyp_alias (x0, x1) -> - Ast_412.Parsetree.Ptyp_alias ((copy_core_type x0), x1) - | Ast_411.Parsetree.Ptyp_variant (x0, x1, x2) -> - Ast_412.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), (copy_closed_flag x1), - (Option.map (fun x -> List.map copy_label x) x2)) - | Ast_411.Parsetree.Ptyp_poly (x0, x1) -> - Ast_412.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | Ast_411.Parsetree.Ptyp_package x0 -> - Ast_412.Parsetree.Ptyp_package (copy_package_type x0) - | Ast_411.Parsetree.Ptyp_extension x0 -> - Ast_412.Parsetree.Ptyp_extension (copy_extension x0) -and copy_package_type : - Ast_411.Parsetree.package_type -> Ast_412.Parsetree.package_type = - fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_core_type x1))) x1)) -and copy_row_field : - Ast_411.Parsetree.row_field -> Ast_412.Parsetree.row_field = - fun - { Ast_411.Parsetree.prf_desc = prf_desc; - Ast_411.Parsetree.prf_loc = prf_loc; - Ast_411.Parsetree.prf_attributes = prf_attributes } - -> - { - Ast_412.Parsetree.prf_desc = (copy_row_field_desc prf_desc); - Ast_412.Parsetree.prf_loc = (copy_location prf_loc); - Ast_412.Parsetree.prf_attributes = (copy_attributes prf_attributes) - } -and copy_row_field_desc : - Ast_411.Parsetree.row_field_desc -> Ast_412.Parsetree.row_field_desc = - function - | Ast_411.Parsetree.Rtag (x0, x1, x2) -> - Ast_412.Parsetree.Rtag - ((copy_loc copy_label x0), x1, (List.map copy_core_type x2)) - | Ast_411.Parsetree.Rinherit x0 -> - Ast_412.Parsetree.Rinherit (copy_core_type x0) -and copy_object_field : - Ast_411.Parsetree.object_field -> Ast_412.Parsetree.object_field = - fun - { Ast_411.Parsetree.pof_desc = pof_desc; - Ast_411.Parsetree.pof_loc = pof_loc; - Ast_411.Parsetree.pof_attributes = pof_attributes } - -> - { - Ast_412.Parsetree.pof_desc = (copy_object_field_desc pof_desc); - Ast_412.Parsetree.pof_loc = (copy_location pof_loc); - Ast_412.Parsetree.pof_attributes = (copy_attributes pof_attributes) - } -and copy_attributes : - Ast_411.Parsetree.attributes -> Ast_412.Parsetree.attributes = - fun x -> List.map copy_attribute x -and copy_attribute : - Ast_411.Parsetree.attribute -> Ast_412.Parsetree.attribute = - fun - { Ast_411.Parsetree.attr_name = attr_name; - Ast_411.Parsetree.attr_payload = attr_payload; - Ast_411.Parsetree.attr_loc = attr_loc } - -> - { - Ast_412.Parsetree.attr_name = (copy_loc (fun x -> x) attr_name); - Ast_412.Parsetree.attr_payload = (copy_payload attr_payload); - Ast_412.Parsetree.attr_loc = (copy_location attr_loc) - } -and copy_payload : Ast_411.Parsetree.payload -> Ast_412.Parsetree.payload = - function - | Ast_411.Parsetree.PStr x0 -> Ast_412.Parsetree.PStr (copy_structure x0) - | Ast_411.Parsetree.PSig x0 -> Ast_412.Parsetree.PSig (copy_signature x0) - | Ast_411.Parsetree.PTyp x0 -> Ast_412.Parsetree.PTyp (copy_core_type x0) - | Ast_411.Parsetree.PPat (x0, x1) -> - Ast_412.Parsetree.PPat - ((copy_pattern x0), (Option.map copy_expression x1)) -and copy_structure : - Ast_411.Parsetree.structure -> Ast_412.Parsetree.structure = - fun x -> List.map copy_structure_item x -and copy_structure_item : - Ast_411.Parsetree.structure_item -> Ast_412.Parsetree.structure_item = - fun - { Ast_411.Parsetree.pstr_desc = pstr_desc; - Ast_411.Parsetree.pstr_loc = pstr_loc } - -> - { - Ast_412.Parsetree.pstr_desc = (copy_structure_item_desc pstr_desc); - Ast_412.Parsetree.pstr_loc = (copy_location pstr_loc) - } -and copy_structure_item_desc : - Ast_411.Parsetree.structure_item_desc -> - Ast_412.Parsetree.structure_item_desc - = - function - | Ast_411.Parsetree.Pstr_eval (x0, x1) -> - Ast_412.Parsetree.Pstr_eval - ((copy_expression x0), (copy_attributes x1)) - | Ast_411.Parsetree.Pstr_value (x0, x1) -> - Ast_412.Parsetree.Pstr_value - ((copy_rec_flag x0), (List.map copy_value_binding x1)) - | Ast_411.Parsetree.Pstr_primitive x0 -> - Ast_412.Parsetree.Pstr_primitive (copy_value_description x0) - | Ast_411.Parsetree.Pstr_type (x0, x1) -> - Ast_412.Parsetree.Pstr_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_411.Parsetree.Pstr_typext x0 -> - Ast_412.Parsetree.Pstr_typext (copy_type_extension x0) - | Ast_411.Parsetree.Pstr_exception x0 -> - Ast_412.Parsetree.Pstr_exception (copy_type_exception x0) - | Ast_411.Parsetree.Pstr_module x0 -> - Ast_412.Parsetree.Pstr_module (copy_module_binding x0) - | Ast_411.Parsetree.Pstr_recmodule x0 -> - Ast_412.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) - | Ast_411.Parsetree.Pstr_modtype x0 -> - Ast_412.Parsetree.Pstr_modtype (copy_module_type_declaration x0) - | Ast_411.Parsetree.Pstr_open x0 -> - Ast_412.Parsetree.Pstr_open (copy_open_declaration x0) - | Ast_411.Parsetree.Pstr_class x0 -> - Ast_412.Parsetree.Pstr_class (List.map copy_class_declaration x0) - | Ast_411.Parsetree.Pstr_class_type x0 -> - Ast_412.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | Ast_411.Parsetree.Pstr_include x0 -> - Ast_412.Parsetree.Pstr_include (copy_include_declaration x0) - | Ast_411.Parsetree.Pstr_attribute x0 -> - Ast_412.Parsetree.Pstr_attribute (copy_attribute x0) - | Ast_411.Parsetree.Pstr_extension (x0, x1) -> - Ast_412.Parsetree.Pstr_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_include_declaration : - Ast_411.Parsetree.include_declaration -> - Ast_412.Parsetree.include_declaration - = fun x -> copy_include_infos copy_module_expr x -and copy_class_declaration : - Ast_411.Parsetree.class_declaration -> Ast_412.Parsetree.class_declaration - = fun x -> copy_class_infos copy_class_expr x -and copy_class_expr : - Ast_411.Parsetree.class_expr -> Ast_412.Parsetree.class_expr = - fun - { Ast_411.Parsetree.pcl_desc = pcl_desc; - Ast_411.Parsetree.pcl_loc = pcl_loc; - Ast_411.Parsetree.pcl_attributes = pcl_attributes } - -> - { - Ast_412.Parsetree.pcl_desc = (copy_class_expr_desc pcl_desc); - Ast_412.Parsetree.pcl_loc = (copy_location pcl_loc); - Ast_412.Parsetree.pcl_attributes = (copy_attributes pcl_attributes) - } -and copy_class_expr_desc : - Ast_411.Parsetree.class_expr_desc -> Ast_412.Parsetree.class_expr_desc = - function - | Ast_411.Parsetree.Pcl_constr (x0, x1) -> - Ast_412.Parsetree.Pcl_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_411.Parsetree.Pcl_structure x0 -> - Ast_412.Parsetree.Pcl_structure (copy_class_structure x0) - | Ast_411.Parsetree.Pcl_fun (x0, x1, x2, x3) -> - Ast_412.Parsetree.Pcl_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_class_expr x3)) - | Ast_411.Parsetree.Pcl_apply (x0, x1) -> - Ast_412.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_411.Parsetree.Pcl_let (x0, x1, x2) -> - Ast_412.Parsetree.Pcl_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_class_expr x2)) - | Ast_411.Parsetree.Pcl_constraint (x0, x1) -> - Ast_412.Parsetree.Pcl_constraint - ((copy_class_expr x0), (copy_class_type x1)) - | Ast_411.Parsetree.Pcl_extension x0 -> - Ast_412.Parsetree.Pcl_extension (copy_extension x0) - | Ast_411.Parsetree.Pcl_open (x0, x1) -> - Ast_412.Parsetree.Pcl_open - ((copy_open_description x0), (copy_class_expr x1)) -and copy_class_structure : - Ast_411.Parsetree.class_structure -> Ast_412.Parsetree.class_structure = - fun - { Ast_411.Parsetree.pcstr_self = pcstr_self; - Ast_411.Parsetree.pcstr_fields = pcstr_fields } - -> - { - Ast_412.Parsetree.pcstr_self = (copy_pattern pcstr_self); - Ast_412.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } -and copy_class_field : - Ast_411.Parsetree.class_field -> Ast_412.Parsetree.class_field = - fun - { Ast_411.Parsetree.pcf_desc = pcf_desc; - Ast_411.Parsetree.pcf_loc = pcf_loc; - Ast_411.Parsetree.pcf_attributes = pcf_attributes } - -> - { - Ast_412.Parsetree.pcf_desc = (copy_class_field_desc pcf_desc); - Ast_412.Parsetree.pcf_loc = (copy_location pcf_loc); - Ast_412.Parsetree.pcf_attributes = (copy_attributes pcf_attributes) - } -and copy_class_field_desc : - Ast_411.Parsetree.class_field_desc -> Ast_412.Parsetree.class_field_desc = - function - | Ast_411.Parsetree.Pcf_inherit (x0, x1, x2) -> - Ast_412.Parsetree.Pcf_inherit - ((copy_override_flag x0), (copy_class_expr x1), - (Option.map (fun x -> copy_loc (fun x -> x) x) x2)) - | Ast_411.Parsetree.Pcf_val x0 -> - Ast_412.Parsetree.Pcf_val - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | Ast_411.Parsetree.Pcf_method x0 -> - Ast_412.Parsetree.Pcf_method - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_class_field_kind x2))) - | Ast_411.Parsetree.Pcf_constraint x0 -> - Ast_412.Parsetree.Pcf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_411.Parsetree.Pcf_initializer x0 -> - Ast_412.Parsetree.Pcf_initializer (copy_expression x0) - | Ast_411.Parsetree.Pcf_attribute x0 -> - Ast_412.Parsetree.Pcf_attribute (copy_attribute x0) - | Ast_411.Parsetree.Pcf_extension x0 -> - Ast_412.Parsetree.Pcf_extension (copy_extension x0) -and copy_class_field_kind : - Ast_411.Parsetree.class_field_kind -> Ast_412.Parsetree.class_field_kind = - function - | Ast_411.Parsetree.Cfk_virtual x0 -> - Ast_412.Parsetree.Cfk_virtual (copy_core_type x0) - | Ast_411.Parsetree.Cfk_concrete (x0, x1) -> - Ast_412.Parsetree.Cfk_concrete - ((copy_override_flag x0), (copy_expression x1)) -and copy_open_declaration : - Ast_411.Parsetree.open_declaration -> Ast_412.Parsetree.open_declaration = - fun x -> copy_open_infos copy_module_expr x -and copy_module_binding : - Ast_411.Parsetree.module_binding -> Ast_412.Parsetree.module_binding = - fun - { Ast_411.Parsetree.pmb_name = pmb_name; - Ast_411.Parsetree.pmb_expr = pmb_expr; - Ast_411.Parsetree.pmb_attributes = pmb_attributes; - Ast_411.Parsetree.pmb_loc = pmb_loc } - -> - { - Ast_412.Parsetree.pmb_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name); - Ast_412.Parsetree.pmb_expr = (copy_module_expr pmb_expr); - Ast_412.Parsetree.pmb_attributes = (copy_attributes pmb_attributes); - Ast_412.Parsetree.pmb_loc = (copy_location pmb_loc) - } -and copy_module_expr : - Ast_411.Parsetree.module_expr -> Ast_412.Parsetree.module_expr = - fun - { Ast_411.Parsetree.pmod_desc = pmod_desc; - Ast_411.Parsetree.pmod_loc = pmod_loc; - Ast_411.Parsetree.pmod_attributes = pmod_attributes } - -> - { - Ast_412.Parsetree.pmod_desc = (copy_module_expr_desc pmod_desc); - Ast_412.Parsetree.pmod_loc = (copy_location pmod_loc); - Ast_412.Parsetree.pmod_attributes = (copy_attributes pmod_attributes) - } -and copy_module_expr_desc : - Ast_411.Parsetree.module_expr_desc -> Ast_412.Parsetree.module_expr_desc = - function - | Ast_411.Parsetree.Pmod_ident x0 -> - Ast_412.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) - | Ast_411.Parsetree.Pmod_structure x0 -> - Ast_412.Parsetree.Pmod_structure (copy_structure x0) - | Ast_411.Parsetree.Pmod_functor (x0, x1) -> - Ast_412.Parsetree.Pmod_functor - ((copy_functor_parameter x0), (copy_module_expr x1)) - | Ast_411.Parsetree.Pmod_apply (x0, x1) -> - Ast_412.Parsetree.Pmod_apply - ((copy_module_expr x0), (copy_module_expr x1)) - | Ast_411.Parsetree.Pmod_constraint (x0, x1) -> - Ast_412.Parsetree.Pmod_constraint - ((copy_module_expr x0), (copy_module_type x1)) - | Ast_411.Parsetree.Pmod_unpack x0 -> - Ast_412.Parsetree.Pmod_unpack (copy_expression x0) - | Ast_411.Parsetree.Pmod_extension x0 -> - Ast_412.Parsetree.Pmod_extension (copy_extension x0) -and copy_functor_parameter : - Ast_411.Parsetree.functor_parameter -> Ast_412.Parsetree.functor_parameter - = - function - | Ast_411.Parsetree.Unit -> Ast_412.Parsetree.Unit - | Ast_411.Parsetree.Named (x0, x1) -> - Ast_412.Parsetree.Named - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_type x1)) -and copy_module_type : - Ast_411.Parsetree.module_type -> Ast_412.Parsetree.module_type = - fun - { Ast_411.Parsetree.pmty_desc = pmty_desc; - Ast_411.Parsetree.pmty_loc = pmty_loc; - Ast_411.Parsetree.pmty_attributes = pmty_attributes } - -> - { - Ast_412.Parsetree.pmty_desc = (copy_module_type_desc pmty_desc); - Ast_412.Parsetree.pmty_loc = (copy_location pmty_loc); - Ast_412.Parsetree.pmty_attributes = (copy_attributes pmty_attributes) - } -and copy_module_type_desc : - Ast_411.Parsetree.module_type_desc -> Ast_412.Parsetree.module_type_desc = - function - | Ast_411.Parsetree.Pmty_ident x0 -> - Ast_412.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) - | Ast_411.Parsetree.Pmty_signature x0 -> - Ast_412.Parsetree.Pmty_signature (copy_signature x0) - | Ast_411.Parsetree.Pmty_functor (x0, x1) -> - Ast_412.Parsetree.Pmty_functor - ((copy_functor_parameter x0), (copy_module_type x1)) - | Ast_411.Parsetree.Pmty_with (x0, x1) -> - Ast_412.Parsetree.Pmty_with - ((copy_module_type x0), (List.map copy_with_constraint x1)) - | Ast_411.Parsetree.Pmty_typeof x0 -> - Ast_412.Parsetree.Pmty_typeof (copy_module_expr x0) - | Ast_411.Parsetree.Pmty_extension x0 -> - Ast_412.Parsetree.Pmty_extension (copy_extension x0) - | Ast_411.Parsetree.Pmty_alias x0 -> - Ast_412.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) -and copy_with_constraint : - Ast_411.Parsetree.with_constraint -> Ast_412.Parsetree.with_constraint = - function - | Ast_411.Parsetree.Pwith_type (x0, x1) -> - Ast_412.Parsetree.Pwith_type - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_411.Parsetree.Pwith_module (x0, x1) -> - Ast_412.Parsetree.Pwith_module - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) - | Ast_411.Parsetree.Pwith_typesubst (x0, x1) -> - Ast_412.Parsetree.Pwith_typesubst - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_411.Parsetree.Pwith_modsubst (x0, x1) -> - Ast_412.Parsetree.Pwith_modsubst - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) -and copy_signature : - Ast_411.Parsetree.signature -> Ast_412.Parsetree.signature = - fun x -> List.map copy_signature_item x -and copy_signature_item : - Ast_411.Parsetree.signature_item -> Ast_412.Parsetree.signature_item = - fun - { Ast_411.Parsetree.psig_desc = psig_desc; - Ast_411.Parsetree.psig_loc = psig_loc } - -> - { - Ast_412.Parsetree.psig_desc = (copy_signature_item_desc psig_desc); - Ast_412.Parsetree.psig_loc = (copy_location psig_loc) - } -and copy_signature_item_desc : - Ast_411.Parsetree.signature_item_desc -> - Ast_412.Parsetree.signature_item_desc - = - function - | Ast_411.Parsetree.Psig_value x0 -> - Ast_412.Parsetree.Psig_value (copy_value_description x0) - | Ast_411.Parsetree.Psig_type (x0, x1) -> - Ast_412.Parsetree.Psig_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_411.Parsetree.Psig_typesubst x0 -> - Ast_412.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) - | Ast_411.Parsetree.Psig_typext x0 -> - Ast_412.Parsetree.Psig_typext (copy_type_extension x0) - | Ast_411.Parsetree.Psig_exception x0 -> - Ast_412.Parsetree.Psig_exception (copy_type_exception x0) - | Ast_411.Parsetree.Psig_module x0 -> - Ast_412.Parsetree.Psig_module (copy_module_declaration x0) - | Ast_411.Parsetree.Psig_modsubst x0 -> - Ast_412.Parsetree.Psig_modsubst (copy_module_substitution x0) - | Ast_411.Parsetree.Psig_recmodule x0 -> - Ast_412.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) - | Ast_411.Parsetree.Psig_modtype x0 -> - Ast_412.Parsetree.Psig_modtype (copy_module_type_declaration x0) - | Ast_411.Parsetree.Psig_open x0 -> - Ast_412.Parsetree.Psig_open (copy_open_description x0) - | Ast_411.Parsetree.Psig_include x0 -> - Ast_412.Parsetree.Psig_include (copy_include_description x0) - | Ast_411.Parsetree.Psig_class x0 -> - Ast_412.Parsetree.Psig_class (List.map copy_class_description x0) - | Ast_411.Parsetree.Psig_class_type x0 -> - Ast_412.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | Ast_411.Parsetree.Psig_attribute x0 -> - Ast_412.Parsetree.Psig_attribute (copy_attribute x0) - | Ast_411.Parsetree.Psig_extension (x0, x1) -> - Ast_412.Parsetree.Psig_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_class_type_declaration : - Ast_411.Parsetree.class_type_declaration -> - Ast_412.Parsetree.class_type_declaration - = fun x -> copy_class_infos copy_class_type x -and copy_class_description : - Ast_411.Parsetree.class_description -> Ast_412.Parsetree.class_description - = fun x -> copy_class_infos copy_class_type x -and copy_class_type : - Ast_411.Parsetree.class_type -> Ast_412.Parsetree.class_type = - fun - { Ast_411.Parsetree.pcty_desc = pcty_desc; - Ast_411.Parsetree.pcty_loc = pcty_loc; - Ast_411.Parsetree.pcty_attributes = pcty_attributes } - -> - { - Ast_412.Parsetree.pcty_desc = (copy_class_type_desc pcty_desc); - Ast_412.Parsetree.pcty_loc = (copy_location pcty_loc); - Ast_412.Parsetree.pcty_attributes = (copy_attributes pcty_attributes) - } -and copy_class_type_desc : - Ast_411.Parsetree.class_type_desc -> Ast_412.Parsetree.class_type_desc = - function - | Ast_411.Parsetree.Pcty_constr (x0, x1) -> - Ast_412.Parsetree.Pcty_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_411.Parsetree.Pcty_signature x0 -> - Ast_412.Parsetree.Pcty_signature (copy_class_signature x0) - | Ast_411.Parsetree.Pcty_arrow (x0, x1, x2) -> - Ast_412.Parsetree.Pcty_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_class_type x2)) - | Ast_411.Parsetree.Pcty_extension x0 -> - Ast_412.Parsetree.Pcty_extension (copy_extension x0) - | Ast_411.Parsetree.Pcty_open (x0, x1) -> - Ast_412.Parsetree.Pcty_open - ((copy_open_description x0), (copy_class_type x1)) -and copy_class_signature : - Ast_411.Parsetree.class_signature -> Ast_412.Parsetree.class_signature = - fun - { Ast_411.Parsetree.pcsig_self = pcsig_self; - Ast_411.Parsetree.pcsig_fields = pcsig_fields } - -> - { - Ast_412.Parsetree.pcsig_self = (copy_core_type pcsig_self); - Ast_412.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } -and copy_class_type_field : - Ast_411.Parsetree.class_type_field -> Ast_412.Parsetree.class_type_field = - fun - { Ast_411.Parsetree.pctf_desc = pctf_desc; - Ast_411.Parsetree.pctf_loc = pctf_loc; - Ast_411.Parsetree.pctf_attributes = pctf_attributes } - -> - { - Ast_412.Parsetree.pctf_desc = (copy_class_type_field_desc pctf_desc); - Ast_412.Parsetree.pctf_loc = (copy_location pctf_loc); - Ast_412.Parsetree.pctf_attributes = (copy_attributes pctf_attributes) - } -and copy_class_type_field_desc : - Ast_411.Parsetree.class_type_field_desc -> - Ast_412.Parsetree.class_type_field_desc - = - function - | Ast_411.Parsetree.Pctf_inherit x0 -> - Ast_412.Parsetree.Pctf_inherit (copy_class_type x0) - | Ast_411.Parsetree.Pctf_val x0 -> - Ast_412.Parsetree.Pctf_val - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_411.Parsetree.Pctf_method x0 -> - Ast_412.Parsetree.Pctf_method - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_411.Parsetree.Pctf_constraint x0 -> - Ast_412.Parsetree.Pctf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_411.Parsetree.Pctf_attribute x0 -> - Ast_412.Parsetree.Pctf_attribute (copy_attribute x0) - | Ast_411.Parsetree.Pctf_extension x0 -> - Ast_412.Parsetree.Pctf_extension (copy_extension x0) -and copy_extension : - Ast_411.Parsetree.extension -> Ast_412.Parsetree.extension = - fun x -> - let (x0, x1) = x in ((copy_loc (fun x -> x) x0), (copy_payload x1)) -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_411.Parsetree.class_infos -> 'g0 Ast_412.Parsetree.class_infos - = - fun f0 -> - fun - { Ast_411.Parsetree.pci_virt = pci_virt; - Ast_411.Parsetree.pci_params = pci_params; - Ast_411.Parsetree.pci_name = pci_name; - Ast_411.Parsetree.pci_expr = pci_expr; - Ast_411.Parsetree.pci_loc = pci_loc; - Ast_411.Parsetree.pci_attributes = pci_attributes } - -> - { - Ast_412.Parsetree.pci_virt = (copy_virtual_flag pci_virt); - Ast_412.Parsetree.pci_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), (copy_variance x1, Ast_412.Asttypes.NoInjectivity))) - pci_params); - Ast_412.Parsetree.pci_name = (copy_loc (fun x -> x) pci_name); - Ast_412.Parsetree.pci_expr = (f0 pci_expr); - Ast_412.Parsetree.pci_loc = (copy_location pci_loc); - Ast_412.Parsetree.pci_attributes = (copy_attributes pci_attributes) - } -and copy_virtual_flag : - Ast_411.Asttypes.virtual_flag -> Ast_412.Asttypes.virtual_flag = - function - | Ast_411.Asttypes.Virtual -> Ast_412.Asttypes.Virtual - | Ast_411.Asttypes.Concrete -> Ast_412.Asttypes.Concrete -and copy_include_description : - Ast_411.Parsetree.include_description -> - Ast_412.Parsetree.include_description - = fun x -> copy_include_infos copy_module_type x -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_411.Parsetree.include_infos -> - 'g0 Ast_412.Parsetree.include_infos - = - fun f0 -> - fun - { Ast_411.Parsetree.pincl_mod = pincl_mod; - Ast_411.Parsetree.pincl_loc = pincl_loc; - Ast_411.Parsetree.pincl_attributes = pincl_attributes } - -> - { - Ast_412.Parsetree.pincl_mod = (f0 pincl_mod); - Ast_412.Parsetree.pincl_loc = (copy_location pincl_loc); - Ast_412.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } -and copy_open_description : - Ast_411.Parsetree.open_description -> Ast_412.Parsetree.open_description = - fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x -and copy_open_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_411.Parsetree.open_infos -> 'g0 Ast_412.Parsetree.open_infos - = - fun f0 -> - fun - { Ast_411.Parsetree.popen_expr = popen_expr; - Ast_411.Parsetree.popen_override = popen_override; - Ast_411.Parsetree.popen_loc = popen_loc; - Ast_411.Parsetree.popen_attributes = popen_attributes } - -> - { - Ast_412.Parsetree.popen_expr = (f0 popen_expr); - Ast_412.Parsetree.popen_override = - (copy_override_flag popen_override); - Ast_412.Parsetree.popen_loc = (copy_location popen_loc); - Ast_412.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } -and copy_override_flag : - Ast_411.Asttypes.override_flag -> Ast_412.Asttypes.override_flag = - function - | Ast_411.Asttypes.Override -> Ast_412.Asttypes.Override - | Ast_411.Asttypes.Fresh -> Ast_412.Asttypes.Fresh -and copy_module_type_declaration : - Ast_411.Parsetree.module_type_declaration -> - Ast_412.Parsetree.module_type_declaration - = - fun - { Ast_411.Parsetree.pmtd_name = pmtd_name; - Ast_411.Parsetree.pmtd_type = pmtd_type; - Ast_411.Parsetree.pmtd_attributes = pmtd_attributes; - Ast_411.Parsetree.pmtd_loc = pmtd_loc } - -> - { - Ast_412.Parsetree.pmtd_name = (copy_loc (fun x -> x) pmtd_name); - Ast_412.Parsetree.pmtd_type = (Option.map copy_module_type pmtd_type); - Ast_412.Parsetree.pmtd_attributes = (copy_attributes pmtd_attributes); - Ast_412.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } -and copy_module_substitution : - Ast_411.Parsetree.module_substitution -> - Ast_412.Parsetree.module_substitution - = - fun - { Ast_411.Parsetree.pms_name = pms_name; - Ast_411.Parsetree.pms_manifest = pms_manifest; - Ast_411.Parsetree.pms_attributes = pms_attributes; - Ast_411.Parsetree.pms_loc = pms_loc } - -> - { - Ast_412.Parsetree.pms_name = (copy_loc (fun x -> x) pms_name); - Ast_412.Parsetree.pms_manifest = - (copy_loc copy_Longident_t pms_manifest); - Ast_412.Parsetree.pms_attributes = (copy_attributes pms_attributes); - Ast_412.Parsetree.pms_loc = (copy_location pms_loc) - } -and copy_module_declaration : - Ast_411.Parsetree.module_declaration -> - Ast_412.Parsetree.module_declaration - = - fun - { Ast_411.Parsetree.pmd_name = pmd_name; - Ast_411.Parsetree.pmd_type = pmd_type; - Ast_411.Parsetree.pmd_attributes = pmd_attributes; - Ast_411.Parsetree.pmd_loc = pmd_loc } - -> - { - Ast_412.Parsetree.pmd_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name); - Ast_412.Parsetree.pmd_type = (copy_module_type pmd_type); - Ast_412.Parsetree.pmd_attributes = (copy_attributes pmd_attributes); - Ast_412.Parsetree.pmd_loc = (copy_location pmd_loc) - } -and copy_type_exception : - Ast_411.Parsetree.type_exception -> Ast_412.Parsetree.type_exception = - fun - { Ast_411.Parsetree.ptyexn_constructor = ptyexn_constructor; - Ast_411.Parsetree.ptyexn_loc = ptyexn_loc; - Ast_411.Parsetree.ptyexn_attributes = ptyexn_attributes } - -> - { - Ast_412.Parsetree.ptyexn_constructor = - (copy_extension_constructor ptyexn_constructor); - Ast_412.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); - Ast_412.Parsetree.ptyexn_attributes = - (copy_attributes ptyexn_attributes) - } -and copy_type_extension : - Ast_411.Parsetree.type_extension -> Ast_412.Parsetree.type_extension = - fun - { Ast_411.Parsetree.ptyext_path = ptyext_path; - Ast_411.Parsetree.ptyext_params = ptyext_params; - Ast_411.Parsetree.ptyext_constructors = ptyext_constructors; - Ast_411.Parsetree.ptyext_private = ptyext_private; - Ast_411.Parsetree.ptyext_loc = ptyext_loc; - Ast_411.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - Ast_412.Parsetree.ptyext_path = (copy_loc copy_Longident_t ptyext_path); - Ast_412.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), (copy_variance x1, Ast_412.Asttypes.NoInjectivity))) - ptyext_params); - Ast_412.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor ptyext_constructors); - Ast_412.Parsetree.ptyext_private = (copy_private_flag ptyext_private); - Ast_412.Parsetree.ptyext_loc = (copy_location ptyext_loc); - Ast_412.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } -and copy_extension_constructor : - Ast_411.Parsetree.extension_constructor -> - Ast_412.Parsetree.extension_constructor - = - fun - { Ast_411.Parsetree.pext_name = pext_name; - Ast_411.Parsetree.pext_kind = pext_kind; - Ast_411.Parsetree.pext_loc = pext_loc; - Ast_411.Parsetree.pext_attributes = pext_attributes } - -> - { - Ast_412.Parsetree.pext_name = (copy_loc (fun x -> x) pext_name); - Ast_412.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - Ast_412.Parsetree.pext_loc = (copy_location pext_loc); - Ast_412.Parsetree.pext_attributes = (copy_attributes pext_attributes) - } -and copy_extension_constructor_kind : - Ast_411.Parsetree.extension_constructor_kind -> - Ast_412.Parsetree.extension_constructor_kind - = - function - | Ast_411.Parsetree.Pext_decl (x0, x1) -> - Ast_412.Parsetree.Pext_decl - ((copy_constructor_arguments x0), (Option.map copy_core_type x1)) - | Ast_411.Parsetree.Pext_rebind x0 -> - Ast_412.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) -and copy_type_declaration : - Ast_411.Parsetree.type_declaration -> Ast_412.Parsetree.type_declaration = - fun - { Ast_411.Parsetree.ptype_name = ptype_name; - Ast_411.Parsetree.ptype_params = ptype_params; - Ast_411.Parsetree.ptype_cstrs = ptype_cstrs; - Ast_411.Parsetree.ptype_kind = ptype_kind; - Ast_411.Parsetree.ptype_private = ptype_private; - Ast_411.Parsetree.ptype_manifest = ptype_manifest; - Ast_411.Parsetree.ptype_attributes = ptype_attributes; - Ast_411.Parsetree.ptype_loc = ptype_loc } - -> - { - Ast_412.Parsetree.ptype_name = (copy_loc (fun x -> x) ptype_name); - Ast_412.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), (copy_variance x1, Ast_412.Asttypes.NoInjectivity))) - ptype_params); - Ast_412.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0, x1, x2) = x in - ((copy_core_type x0), (copy_core_type x1), (copy_location x2))) - ptype_cstrs); - Ast_412.Parsetree.ptype_kind = (copy_type_kind ptype_kind); - Ast_412.Parsetree.ptype_private = (copy_private_flag ptype_private); - Ast_412.Parsetree.ptype_manifest = - (Option.map copy_core_type ptype_manifest); - Ast_412.Parsetree.ptype_attributes = (copy_attributes ptype_attributes); - Ast_412.Parsetree.ptype_loc = (copy_location ptype_loc) - } -and copy_private_flag : - Ast_411.Asttypes.private_flag -> Ast_412.Asttypes.private_flag = - function - | Ast_411.Asttypes.Private -> Ast_412.Asttypes.Private - | Ast_411.Asttypes.Public -> Ast_412.Asttypes.Public -and copy_type_kind : - Ast_411.Parsetree.type_kind -> Ast_412.Parsetree.type_kind = - function - | Ast_411.Parsetree.Ptype_abstract -> Ast_412.Parsetree.Ptype_abstract - | Ast_411.Parsetree.Ptype_variant x0 -> - Ast_412.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | Ast_411.Parsetree.Ptype_record x0 -> - Ast_412.Parsetree.Ptype_record (List.map copy_label_declaration x0) - | Ast_411.Parsetree.Ptype_open -> Ast_412.Parsetree.Ptype_open -and copy_constructor_declaration : - Ast_411.Parsetree.constructor_declaration -> - Ast_412.Parsetree.constructor_declaration - = - fun - { Ast_411.Parsetree.pcd_name = pcd_name; - Ast_411.Parsetree.pcd_args = pcd_args; - Ast_411.Parsetree.pcd_res = pcd_res; - Ast_411.Parsetree.pcd_loc = pcd_loc; - Ast_411.Parsetree.pcd_attributes = pcd_attributes } - -> - { - Ast_412.Parsetree.pcd_name = (copy_loc (fun x -> x) pcd_name); - Ast_412.Parsetree.pcd_args = (copy_constructor_arguments pcd_args); - Ast_412.Parsetree.pcd_res = (Option.map copy_core_type pcd_res); - Ast_412.Parsetree.pcd_loc = (copy_location pcd_loc); - Ast_412.Parsetree.pcd_attributes = (copy_attributes pcd_attributes) - } -and copy_constructor_arguments : - Ast_411.Parsetree.constructor_arguments -> - Ast_412.Parsetree.constructor_arguments - = - function - | Ast_411.Parsetree.Pcstr_tuple x0 -> - Ast_412.Parsetree.Pcstr_tuple (List.map copy_core_type x0) - | Ast_411.Parsetree.Pcstr_record x0 -> - Ast_412.Parsetree.Pcstr_record (List.map copy_label_declaration x0) -and copy_label_declaration : - Ast_411.Parsetree.label_declaration -> Ast_412.Parsetree.label_declaration - = - fun - { Ast_411.Parsetree.pld_name = pld_name; - Ast_411.Parsetree.pld_mutable = pld_mutable; - Ast_411.Parsetree.pld_type = pld_type; - Ast_411.Parsetree.pld_loc = pld_loc; - Ast_411.Parsetree.pld_attributes = pld_attributes } - -> - { - Ast_412.Parsetree.pld_name = (copy_loc (fun x -> x) pld_name); - Ast_412.Parsetree.pld_mutable = (copy_mutable_flag pld_mutable); - Ast_412.Parsetree.pld_type = (copy_core_type pld_type); - Ast_412.Parsetree.pld_loc = (copy_location pld_loc); - Ast_412.Parsetree.pld_attributes = (copy_attributes pld_attributes) - } -and copy_mutable_flag : - Ast_411.Asttypes.mutable_flag -> Ast_412.Asttypes.mutable_flag = - function - | Ast_411.Asttypes.Immutable -> Ast_412.Asttypes.Immutable - | Ast_411.Asttypes.Mutable -> Ast_412.Asttypes.Mutable -and copy_variance : Ast_411.Asttypes.variance -> Ast_412.Asttypes.variance = - function - | Ast_411.Asttypes.Covariant -> Ast_412.Asttypes.Covariant - | Ast_411.Asttypes.Contravariant -> Ast_412.Asttypes.Contravariant - | Ast_411.Asttypes.Invariant -> Ast_412.Asttypes.NoVariance -and copy_value_description : - Ast_411.Parsetree.value_description -> Ast_412.Parsetree.value_description - = - fun - { Ast_411.Parsetree.pval_name = pval_name; - Ast_411.Parsetree.pval_type = pval_type; - Ast_411.Parsetree.pval_prim = pval_prim; - Ast_411.Parsetree.pval_attributes = pval_attributes; - Ast_411.Parsetree.pval_loc = pval_loc } - -> - { - Ast_412.Parsetree.pval_name = (copy_loc (fun x -> x) pval_name); - Ast_412.Parsetree.pval_type = (copy_core_type pval_type); - Ast_412.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - Ast_412.Parsetree.pval_attributes = (copy_attributes pval_attributes); - Ast_412.Parsetree.pval_loc = (copy_location pval_loc) - } -and copy_object_field_desc : - Ast_411.Parsetree.object_field_desc -> Ast_412.Parsetree.object_field_desc - = - function - | Ast_411.Parsetree.Otag (x0, x1) -> - Ast_412.Parsetree.Otag ((copy_loc copy_label x0), (copy_core_type x1)) - | Ast_411.Parsetree.Oinherit x0 -> - Ast_412.Parsetree.Oinherit (copy_core_type x0) -and copy_arg_label : Ast_411.Asttypes.arg_label -> Ast_412.Asttypes.arg_label - = - function - | Ast_411.Asttypes.Nolabel -> Ast_412.Asttypes.Nolabel - | Ast_411.Asttypes.Labelled x0 -> Ast_412.Asttypes.Labelled x0 - | Ast_411.Asttypes.Optional x0 -> Ast_412.Asttypes.Optional x0 -and copy_closed_flag : - Ast_411.Asttypes.closed_flag -> Ast_412.Asttypes.closed_flag = - function - | Ast_411.Asttypes.Closed -> Ast_412.Asttypes.Closed - | Ast_411.Asttypes.Open -> Ast_412.Asttypes.Open -and copy_label : Ast_411.Asttypes.label -> Ast_412.Asttypes.label = - fun x -> x -and copy_rec_flag : Ast_411.Asttypes.rec_flag -> Ast_412.Asttypes.rec_flag = - function - | Ast_411.Asttypes.Nonrecursive -> Ast_412.Asttypes.Nonrecursive - | Ast_411.Asttypes.Recursive -> Ast_412.Asttypes.Recursive -and copy_constant : Ast_411.Parsetree.constant -> Ast_412.Parsetree.constant - = - function - | Ast_411.Parsetree.Pconst_integer (x0, x1) -> - Ast_412.Parsetree.Pconst_integer (x0, (Option.map (fun x -> x) x1)) - | Ast_411.Parsetree.Pconst_char x0 -> Ast_412.Parsetree.Pconst_char x0 - | Ast_411.Parsetree.Pconst_string (x0, x1, x2) -> - Ast_412.Parsetree.Pconst_string - (x0, (copy_location x1), (Option.map (fun x -> x) x2)) - | Ast_411.Parsetree.Pconst_float (x0, x1) -> - Ast_412.Parsetree.Pconst_float (x0, (Option.map (fun x -> x) x1)) -and copy_Longident_t : Longident.t -> Longident.t = - function - | Longident.Lident x0 -> Longident.Lident x0 - | Longident.Ldot (x0, x1) -> Longident.Ldot ((copy_Longident_t x0), x1) - | Longident.Lapply (x0, x1) -> - Longident.Lapply ((copy_Longident_t x0), (copy_Longident_t x1)) -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 Ast_411.Asttypes.loc -> 'g0 Ast_412.Asttypes.loc - = - fun f0 -> - fun { Ast_411.Asttypes.txt = txt; Ast_411.Asttypes.loc = loc } -> - { - Ast_412.Asttypes.txt = (f0 txt); - Ast_412.Asttypes.loc = (copy_location loc) - } -and copy_location : Location.t -> Location.t = - fun - { Location.loc_start = loc_start; Location.loc_end = loc_end; - Location.loc_ghost = loc_ghost } - -> - { - Location.loc_start = (copy_position loc_start); - Location.loc_end = (copy_position loc_end); - Location.loc_ghost = loc_ghost - } -and copy_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum - } diff --git a/src/vendored-omp/src/migrate_parsetree_412_411.ml b/src/vendored-omp/src/migrate_parsetree_412_411.ml index 644edca0b..067b2d9e3 100644 --- a/src/vendored-omp/src/migrate_parsetree_412_411.ml +++ b/src/vendored-omp/src/migrate_parsetree_412_411.ml @@ -15,130 +15,3 @@ include Migrate_parsetree_412_411_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload"; - "binding_op"; "module_substitution"; "open_declaration"; "type_exception"; - "constant" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - binding_op; - module_substitution; - open_declaration; - type_exception; - constant; - (*$*) - } as mapper) -> - - let module Def = Migrate_parsetree_def in - let module R = Migrate_parsetree_411_412_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> copy_cases (cases mapper (R.copy_cases x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expr (expr mapper (R.copy_expr x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pat (pat mapper (R.copy_pat x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_typ (typ mapper (R.copy_typ x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - binding_op = (fun _ x -> copy_binding_op (binding_op mapper (R.copy_binding_op x))); - module_substitution = (fun _ x -> copy_module_substitution (module_substitution mapper (R.copy_module_substitution x))); - open_declaration = (fun _ x -> copy_open_declaration (open_declaration mapper (R.copy_open_declaration x))); - type_exception = (fun _ x -> copy_type_exception (type_exception mapper (R.copy_type_exception x))); - constant = (fun _ x -> copy_constant (constant mapper (R.copy_constant x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_412_411_migrate.ml b/src/vendored-omp/src/migrate_parsetree_412_411_migrate.ml index f897fd91f..03dc65522 100644 --- a/src/vendored-omp/src/migrate_parsetree_412_411_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_412_411_migrate.ml @@ -1,7 +1,6 @@ open Stdlib0 module From = Ast_412 module To = Ast_411 - let rec copy_out_type_extension : Ast_412.Outcometree.out_type_extension -> Ast_411.Outcometree.out_type_extension @@ -38,35 +37,17 @@ and copy_out_phrase : | Ast_412.Outcometree.Ophr_exception x0 -> Ast_411.Outcometree.Ophr_exception (let (x0, x1) = x0 in (x0, (copy_out_value x1))) - -and copy_out_type_param : Ast_412.Outcometree.out_type_param -> string * (bool * bool) = - function (str, (v,inj)) -> - (match inj with - | Ast_412.Asttypes.NoInjectivity -> () - | Ast_412.Asttypes.Injective -> - (* ignoring [Injective] is not quite correct *) - () - ); - let co, cn = - match v with - | Ast_412.Asttypes.Covariant -> (true, false) - | Ast_412.Asttypes.Contravariant -> (false, true) - | Ast_412.Asttypes.NoVariance -> (false, false) - in - str, (co, cn) and copy_out_sig_item : Ast_412.Outcometree.out_sig_item -> Ast_411.Outcometree.out_sig_item = function | Ast_412.Outcometree.Osig_class (x0, x1, x2, x3, x4) -> Ast_411.Outcometree.Osig_class - (x0, x1, - (List.map copy_out_type_param x2), - (copy_out_class_type x3), (copy_out_rec_status x4)) + (x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3), + (copy_out_rec_status x4)) | Ast_412.Outcometree.Osig_class_type (x0, x1, x2, x3, x4) -> Ast_411.Outcometree.Osig_class_type - (x0, x1, - (List.map copy_out_type_param x2), - (copy_out_class_type x3), (copy_out_rec_status x4)) + (x0, x1, (List.map copy_out_type_param x2), (copy_out_class_type x3), + (copy_out_rec_status x4)) | Ast_412.Outcometree.Osig_typext (x0, x1) -> Ast_411.Outcometree.Osig_typext ((copy_out_extension_constructor x0), (copy_out_ext_status x1)) @@ -175,6 +156,11 @@ and copy_out_extension_constructor : (Option.map copy_out_type oext_ret_type); Ast_411.Outcometree.oext_private = (copy_private_flag oext_private) } +and copy_private_flag : + Ast_412.Asttypes.private_flag -> Ast_411.Asttypes.private_flag = + function + | Ast_412.Asttypes.Private -> Ast_411.Asttypes.Private + | Ast_412.Asttypes.Public -> Ast_411.Asttypes.Public and copy_out_rec_status : Ast_412.Outcometree.out_rec_status -> Ast_411.Outcometree.out_rec_status = function @@ -206,6 +192,26 @@ and copy_out_class_sig_item : Ast_411.Outcometree.Ocsg_method (x0, x1, x2, (copy_out_type x3)) | Ast_412.Outcometree.Ocsg_value (x0, x1, x2, x3) -> Ast_411.Outcometree.Ocsg_value (x0, x1, x2, (copy_out_type x3)) +and copy_out_type_param : Ast_412.Outcometree.out_type_param -> string * (bool * bool) = + function (str, (v,inj)) -> + (match inj with + | Ast_412.Asttypes.NoInjectivity -> () + | Ast_412.Asttypes.Injective -> + (* ignoring [Injective] is not quite correct *) + () + ); + let co, cn = + match v with + | Ast_412.Asttypes.Covariant -> (true, false) + | Ast_412.Asttypes.Contravariant -> (false, true) + | Ast_412.Asttypes.NoVariance -> (false, false) + in + str, (co, cn) +and copy_variance : Ast_412.Asttypes.variance -> Ast_411.Asttypes.variance = + function + | Ast_412.Asttypes.Covariant -> Ast_411.Asttypes.Covariant + | Ast_412.Asttypes.Contravariant -> Ast_411.Asttypes.Contravariant + | Ast_412.Asttypes.NoVariance -> Ast_411.Asttypes.Invariant and copy_out_type : Ast_412.Outcometree.out_type -> Ast_411.Outcometree.out_type = function @@ -326,1215 +332,3 @@ and copy_out_name : Ast_412.Outcometree.out_name -> Ast_411.Outcometree.out_name = fun { Ast_412.Outcometree.printed_name = printed_name } -> { Ast_411.Outcometree.printed_name = printed_name } - -and copy_toplevel_phrase : - Ast_412.Parsetree.toplevel_phrase -> Ast_411.Parsetree.toplevel_phrase = - function - | Ast_412.Parsetree.Ptop_def x0 -> - Ast_411.Parsetree.Ptop_def (copy_structure x0) - | Ast_412.Parsetree.Ptop_dir x0 -> - Ast_411.Parsetree.Ptop_dir (copy_toplevel_directive x0) -and copy_toplevel_directive : - Ast_412.Parsetree.toplevel_directive -> - Ast_411.Parsetree.toplevel_directive - = - fun - { Ast_412.Parsetree.pdir_name = pdir_name; - Ast_412.Parsetree.pdir_arg = pdir_arg; - Ast_412.Parsetree.pdir_loc = pdir_loc } - -> - { - Ast_411.Parsetree.pdir_name = (copy_loc (fun x -> x) pdir_name); - Ast_411.Parsetree.pdir_arg = - (Option.map copy_directive_argument pdir_arg); - Ast_411.Parsetree.pdir_loc = (copy_location pdir_loc) - } -and copy_directive_argument : - Ast_412.Parsetree.directive_argument -> - Ast_411.Parsetree.directive_argument - = - fun - { Ast_412.Parsetree.pdira_desc = pdira_desc; - Ast_412.Parsetree.pdira_loc = pdira_loc } - -> - { - Ast_411.Parsetree.pdira_desc = - (copy_directive_argument_desc pdira_desc); - Ast_411.Parsetree.pdira_loc = (copy_location pdira_loc) - } -and copy_directive_argument_desc : - Ast_412.Parsetree.directive_argument_desc -> - Ast_411.Parsetree.directive_argument_desc - = - function - | Ast_412.Parsetree.Pdir_string x0 -> Ast_411.Parsetree.Pdir_string x0 - | Ast_412.Parsetree.Pdir_int (x0, x1) -> - Ast_411.Parsetree.Pdir_int (x0, (Option.map (fun x -> x) x1)) - | Ast_412.Parsetree.Pdir_ident x0 -> - Ast_411.Parsetree.Pdir_ident (copy_Longident_t x0) - | Ast_412.Parsetree.Pdir_bool x0 -> Ast_411.Parsetree.Pdir_bool x0 -and copy_expression : - Ast_412.Parsetree.expression -> Ast_411.Parsetree.expression = - fun - { Ast_412.Parsetree.pexp_desc = pexp_desc; - Ast_412.Parsetree.pexp_loc = pexp_loc; - Ast_412.Parsetree.pexp_loc_stack = pexp_loc_stack; - Ast_412.Parsetree.pexp_attributes = pexp_attributes } - -> - { - Ast_411.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - Ast_411.Parsetree.pexp_loc = (copy_location pexp_loc); - Ast_411.Parsetree.pexp_loc_stack = (copy_location_stack pexp_loc_stack); - Ast_411.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } -and copy_expr x = copy_expression x -and copy_expression_desc : - Ast_412.Parsetree.expression_desc -> Ast_411.Parsetree.expression_desc = - function - | Ast_412.Parsetree.Pexp_ident x0 -> - Ast_411.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) - | Ast_412.Parsetree.Pexp_constant x0 -> - Ast_411.Parsetree.Pexp_constant (copy_constant x0) - | Ast_412.Parsetree.Pexp_let (x0, x1, x2) -> - Ast_411.Parsetree.Pexp_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_expression x2)) - | Ast_412.Parsetree.Pexp_function x0 -> - Ast_411.Parsetree.Pexp_function (List.map copy_case x0) - | Ast_412.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_411.Parsetree.Pexp_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_expression x3)) - | Ast_412.Parsetree.Pexp_apply (x0, x1) -> - Ast_411.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_412.Parsetree.Pexp_match (x0, x1) -> - Ast_411.Parsetree.Pexp_match - ((copy_expression x0), (List.map copy_case x1)) - | Ast_412.Parsetree.Pexp_try (x0, x1) -> - Ast_411.Parsetree.Pexp_try - ((copy_expression x0), (List.map copy_case x1)) - | Ast_412.Parsetree.Pexp_tuple x0 -> - Ast_411.Parsetree.Pexp_tuple (List.map copy_expression x0) - | Ast_412.Parsetree.Pexp_construct (x0, x1) -> - Ast_411.Parsetree.Pexp_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_expression x1)) - | Ast_412.Parsetree.Pexp_variant (x0, x1) -> - Ast_411.Parsetree.Pexp_variant - ((copy_label x0), (Option.map copy_expression x1)) - | Ast_412.Parsetree.Pexp_record (x0, x1) -> - Ast_411.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_expression x1))) x0), - (Option.map copy_expression x1)) - | Ast_412.Parsetree.Pexp_field (x0, x1) -> - Ast_411.Parsetree.Pexp_field - ((copy_expression x0), (copy_loc copy_Longident_t x1)) - | Ast_412.Parsetree.Pexp_setfield (x0, x1, x2) -> - Ast_411.Parsetree.Pexp_setfield - ((copy_expression x0), (copy_loc copy_Longident_t x1), - (copy_expression x2)) - | Ast_412.Parsetree.Pexp_array x0 -> - Ast_411.Parsetree.Pexp_array (List.map copy_expression x0) - | Ast_412.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> - Ast_411.Parsetree.Pexp_ifthenelse - ((copy_expression x0), (copy_expression x1), - (Option.map copy_expression x2)) - | Ast_412.Parsetree.Pexp_sequence (x0, x1) -> - Ast_411.Parsetree.Pexp_sequence - ((copy_expression x0), (copy_expression x1)) - | Ast_412.Parsetree.Pexp_while (x0, x1) -> - Ast_411.Parsetree.Pexp_while - ((copy_expression x0), (copy_expression x1)) - | Ast_412.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> - Ast_411.Parsetree.Pexp_for - ((copy_pattern x0), (copy_expression x1), (copy_expression x2), - (copy_direction_flag x3), (copy_expression x4)) - | Ast_412.Parsetree.Pexp_constraint (x0, x1) -> - Ast_411.Parsetree.Pexp_constraint - ((copy_expression x0), (copy_core_type x1)) - | Ast_412.Parsetree.Pexp_coerce (x0, x1, x2) -> - Ast_411.Parsetree.Pexp_coerce - ((copy_expression x0), (Option.map copy_core_type x1), - (copy_core_type x2)) - | Ast_412.Parsetree.Pexp_send (x0, x1) -> - Ast_411.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc copy_label x1)) - | Ast_412.Parsetree.Pexp_new x0 -> - Ast_411.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) - | Ast_412.Parsetree.Pexp_setinstvar (x0, x1) -> - Ast_411.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), (copy_expression x1)) - | Ast_412.Parsetree.Pexp_override x0 -> - Ast_411.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_label x0), (copy_expression x1))) x0) - | Ast_412.Parsetree.Pexp_letmodule (x0, x1, x2) -> - Ast_411.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_expr x1), (copy_expression x2)) - | Ast_412.Parsetree.Pexp_letexception (x0, x1) -> - Ast_411.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), (copy_expression x1)) - | Ast_412.Parsetree.Pexp_assert x0 -> - Ast_411.Parsetree.Pexp_assert (copy_expression x0) - | Ast_412.Parsetree.Pexp_lazy x0 -> - Ast_411.Parsetree.Pexp_lazy (copy_expression x0) - | Ast_412.Parsetree.Pexp_poly (x0, x1) -> - Ast_411.Parsetree.Pexp_poly - ((copy_expression x0), (Option.map copy_core_type x1)) - | Ast_412.Parsetree.Pexp_object x0 -> - Ast_411.Parsetree.Pexp_object (copy_class_structure x0) - | Ast_412.Parsetree.Pexp_newtype (x0, x1) -> - Ast_411.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | Ast_412.Parsetree.Pexp_pack x0 -> - Ast_411.Parsetree.Pexp_pack (copy_module_expr x0) - | Ast_412.Parsetree.Pexp_open (x0, x1) -> - Ast_411.Parsetree.Pexp_open - ((copy_open_declaration x0), (copy_expression x1)) - | Ast_412.Parsetree.Pexp_letop x0 -> - Ast_411.Parsetree.Pexp_letop (copy_letop x0) - | Ast_412.Parsetree.Pexp_extension x0 -> - Ast_411.Parsetree.Pexp_extension (copy_extension x0) - | Ast_412.Parsetree.Pexp_unreachable -> Ast_411.Parsetree.Pexp_unreachable -and copy_letop : Ast_412.Parsetree.letop -> Ast_411.Parsetree.letop = - fun - { Ast_412.Parsetree.let_ = let_; Ast_412.Parsetree.ands = ands; - Ast_412.Parsetree.body = body } - -> - { - Ast_411.Parsetree.let_ = (copy_binding_op let_); - Ast_411.Parsetree.ands = (List.map copy_binding_op ands); - Ast_411.Parsetree.body = (copy_expression body) - } -and copy_binding_op : - Ast_412.Parsetree.binding_op -> Ast_411.Parsetree.binding_op = - fun - { Ast_412.Parsetree.pbop_op = pbop_op; - Ast_412.Parsetree.pbop_pat = pbop_pat; - Ast_412.Parsetree.pbop_exp = pbop_exp; - Ast_412.Parsetree.pbop_loc = pbop_loc } - -> - { - Ast_411.Parsetree.pbop_op = (copy_loc (fun x -> x) pbop_op); - Ast_411.Parsetree.pbop_pat = (copy_pattern pbop_pat); - Ast_411.Parsetree.pbop_exp = (copy_expression pbop_exp); - Ast_411.Parsetree.pbop_loc = (copy_location pbop_loc) - } -and copy_direction_flag : - Ast_412.Asttypes.direction_flag -> Ast_411.Asttypes.direction_flag = - function - | Ast_412.Asttypes.Upto -> Ast_411.Asttypes.Upto - | Ast_412.Asttypes.Downto -> Ast_411.Asttypes.Downto - -and copy_cases : Ast_412.Parsetree.case list -> Ast_411.Parsetree.case list = - fun x -> List.map copy_case x -and copy_case : Ast_412.Parsetree.case -> Ast_411.Parsetree.case = - fun - { Ast_412.Parsetree.pc_lhs = pc_lhs; - Ast_412.Parsetree.pc_guard = pc_guard; - Ast_412.Parsetree.pc_rhs = pc_rhs } - -> - { - Ast_411.Parsetree.pc_lhs = (copy_pattern pc_lhs); - Ast_411.Parsetree.pc_guard = (Option.map copy_expression pc_guard); - Ast_411.Parsetree.pc_rhs = (copy_expression pc_rhs) - } -and copy_value_binding : - Ast_412.Parsetree.value_binding -> Ast_411.Parsetree.value_binding = - fun - { Ast_412.Parsetree.pvb_pat = pvb_pat; - Ast_412.Parsetree.pvb_expr = pvb_expr; - Ast_412.Parsetree.pvb_attributes = pvb_attributes; - Ast_412.Parsetree.pvb_loc = pvb_loc } - -> - { - Ast_411.Parsetree.pvb_pat = (copy_pattern pvb_pat); - Ast_411.Parsetree.pvb_expr = (copy_expression pvb_expr); - Ast_411.Parsetree.pvb_attributes = (copy_attributes pvb_attributes); - Ast_411.Parsetree.pvb_loc = (copy_location pvb_loc) - } -and copy_pattern : Ast_412.Parsetree.pattern -> Ast_411.Parsetree.pattern = - fun - { Ast_412.Parsetree.ppat_desc = ppat_desc; - Ast_412.Parsetree.ppat_loc = ppat_loc; - Ast_412.Parsetree.ppat_loc_stack = ppat_loc_stack; - Ast_412.Parsetree.ppat_attributes = ppat_attributes } - -> - { - Ast_411.Parsetree.ppat_desc = (copy_pattern_desc ppat_desc); - Ast_411.Parsetree.ppat_loc = (copy_location ppat_loc); - Ast_411.Parsetree.ppat_loc_stack = (copy_location_stack ppat_loc_stack); - Ast_411.Parsetree.ppat_attributes = (copy_attributes ppat_attributes) - } -and copy_pat x = copy_pattern x -and copy_pattern_desc : - Ast_412.Parsetree.pattern_desc -> Ast_411.Parsetree.pattern_desc = - function - | Ast_412.Parsetree.Ppat_any -> Ast_411.Parsetree.Ppat_any - | Ast_412.Parsetree.Ppat_var x0 -> - Ast_411.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | Ast_412.Parsetree.Ppat_alias (x0, x1) -> - Ast_411.Parsetree.Ppat_alias - ((copy_pattern x0), (copy_loc (fun x -> x) x1)) - | Ast_412.Parsetree.Ppat_constant x0 -> - Ast_411.Parsetree.Ppat_constant (copy_constant x0) - | Ast_412.Parsetree.Ppat_interval (x0, x1) -> - Ast_411.Parsetree.Ppat_interval - ((copy_constant x0), (copy_constant x1)) - | Ast_412.Parsetree.Ppat_tuple x0 -> - Ast_411.Parsetree.Ppat_tuple (List.map copy_pattern x0) - | Ast_412.Parsetree.Ppat_construct (x0, x1) -> - Ast_411.Parsetree.Ppat_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_pattern x1)) - | Ast_412.Parsetree.Ppat_variant (x0, x1) -> - Ast_411.Parsetree.Ppat_variant - ((copy_label x0), (Option.map copy_pattern x1)) - | Ast_412.Parsetree.Ppat_record (x0, x1) -> - Ast_411.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | Ast_412.Parsetree.Ppat_array x0 -> - Ast_411.Parsetree.Ppat_array (List.map copy_pattern x0) - | Ast_412.Parsetree.Ppat_or (x0, x1) -> - Ast_411.Parsetree.Ppat_or ((copy_pattern x0), (copy_pattern x1)) - | Ast_412.Parsetree.Ppat_constraint (x0, x1) -> - Ast_411.Parsetree.Ppat_constraint - ((copy_pattern x0), (copy_core_type x1)) - | Ast_412.Parsetree.Ppat_type x0 -> - Ast_411.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) - | Ast_412.Parsetree.Ppat_lazy x0 -> - Ast_411.Parsetree.Ppat_lazy (copy_pattern x0) - | Ast_412.Parsetree.Ppat_unpack x0 -> - Ast_411.Parsetree.Ppat_unpack - (copy_loc (fun x -> Option.map (fun x -> x) x) x0) - | Ast_412.Parsetree.Ppat_exception x0 -> - Ast_411.Parsetree.Ppat_exception (copy_pattern x0) - | Ast_412.Parsetree.Ppat_extension x0 -> - Ast_411.Parsetree.Ppat_extension (copy_extension x0) - | Ast_412.Parsetree.Ppat_open (x0, x1) -> - Ast_411.Parsetree.Ppat_open - ((copy_loc copy_Longident_t x0), (copy_pattern x1)) -and copy_core_type : - Ast_412.Parsetree.core_type -> Ast_411.Parsetree.core_type = - fun - { Ast_412.Parsetree.ptyp_desc = ptyp_desc; - Ast_412.Parsetree.ptyp_loc = ptyp_loc; - Ast_412.Parsetree.ptyp_loc_stack = ptyp_loc_stack; - Ast_412.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - Ast_411.Parsetree.ptyp_desc = (copy_core_type_desc ptyp_desc); - Ast_411.Parsetree.ptyp_loc = (copy_location ptyp_loc); - Ast_411.Parsetree.ptyp_loc_stack = (copy_location_stack ptyp_loc_stack); - Ast_411.Parsetree.ptyp_attributes = (copy_attributes ptyp_attributes) - } -and copy_typ x = copy_core_type x -and copy_location_stack : - Ast_412.Parsetree.location_stack -> Ast_411.Parsetree.location_stack = - fun x -> List.map copy_location x -and copy_core_type_desc : - Ast_412.Parsetree.core_type_desc -> Ast_411.Parsetree.core_type_desc = - function - | Ast_412.Parsetree.Ptyp_any -> Ast_411.Parsetree.Ptyp_any - | Ast_412.Parsetree.Ptyp_var x0 -> Ast_411.Parsetree.Ptyp_var x0 - | Ast_412.Parsetree.Ptyp_arrow (x0, x1, x2) -> - Ast_411.Parsetree.Ptyp_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_core_type x2)) - | Ast_412.Parsetree.Ptyp_tuple x0 -> - Ast_411.Parsetree.Ptyp_tuple (List.map copy_core_type x0) - | Ast_412.Parsetree.Ptyp_constr (x0, x1) -> - Ast_411.Parsetree.Ptyp_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_412.Parsetree.Ptyp_object (x0, x1) -> - Ast_411.Parsetree.Ptyp_object - ((List.map copy_object_field x0), (copy_closed_flag x1)) - | Ast_412.Parsetree.Ptyp_class (x0, x1) -> - Ast_411.Parsetree.Ptyp_class - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_412.Parsetree.Ptyp_alias (x0, x1) -> - Ast_411.Parsetree.Ptyp_alias ((copy_core_type x0), x1) - | Ast_412.Parsetree.Ptyp_variant (x0, x1, x2) -> - Ast_411.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), (copy_closed_flag x1), - (Option.map (fun x -> List.map copy_label x) x2)) - | Ast_412.Parsetree.Ptyp_poly (x0, x1) -> - Ast_411.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | Ast_412.Parsetree.Ptyp_package x0 -> - Ast_411.Parsetree.Ptyp_package (copy_package_type x0) - | Ast_412.Parsetree.Ptyp_extension x0 -> - Ast_411.Parsetree.Ptyp_extension (copy_extension x0) -and copy_package_type : - Ast_412.Parsetree.package_type -> Ast_411.Parsetree.package_type = - fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_core_type x1))) x1)) -and copy_row_field : - Ast_412.Parsetree.row_field -> Ast_411.Parsetree.row_field = - fun - { Ast_412.Parsetree.prf_desc = prf_desc; - Ast_412.Parsetree.prf_loc = prf_loc; - Ast_412.Parsetree.prf_attributes = prf_attributes } - -> - { - Ast_411.Parsetree.prf_desc = (copy_row_field_desc prf_desc); - Ast_411.Parsetree.prf_loc = (copy_location prf_loc); - Ast_411.Parsetree.prf_attributes = (copy_attributes prf_attributes) - } -and copy_row_field_desc : - Ast_412.Parsetree.row_field_desc -> Ast_411.Parsetree.row_field_desc = - function - | Ast_412.Parsetree.Rtag (x0, x1, x2) -> - Ast_411.Parsetree.Rtag - ((copy_loc copy_label x0), x1, (List.map copy_core_type x2)) - | Ast_412.Parsetree.Rinherit x0 -> - Ast_411.Parsetree.Rinherit (copy_core_type x0) -and copy_object_field : - Ast_412.Parsetree.object_field -> Ast_411.Parsetree.object_field = - fun - { Ast_412.Parsetree.pof_desc = pof_desc; - Ast_412.Parsetree.pof_loc = pof_loc; - Ast_412.Parsetree.pof_attributes = pof_attributes } - -> - { - Ast_411.Parsetree.pof_desc = (copy_object_field_desc pof_desc); - Ast_411.Parsetree.pof_loc = (copy_location pof_loc); - Ast_411.Parsetree.pof_attributes = (copy_attributes pof_attributes) - } -and copy_attributes : - Ast_412.Parsetree.attributes -> Ast_411.Parsetree.attributes = - fun x -> List.map copy_attribute x -and copy_attribute : - Ast_412.Parsetree.attribute -> Ast_411.Parsetree.attribute = - fun - { Ast_412.Parsetree.attr_name = attr_name; - Ast_412.Parsetree.attr_payload = attr_payload; - Ast_412.Parsetree.attr_loc = attr_loc } - -> - { - Ast_411.Parsetree.attr_name = (copy_loc (fun x -> x) attr_name); - Ast_411.Parsetree.attr_payload = (copy_payload attr_payload); - Ast_411.Parsetree.attr_loc = (copy_location attr_loc) - } -and copy_payload : Ast_412.Parsetree.payload -> Ast_411.Parsetree.payload = - function - | Ast_412.Parsetree.PStr x0 -> Ast_411.Parsetree.PStr (copy_structure x0) - | Ast_412.Parsetree.PSig x0 -> Ast_411.Parsetree.PSig (copy_signature x0) - | Ast_412.Parsetree.PTyp x0 -> Ast_411.Parsetree.PTyp (copy_core_type x0) - | Ast_412.Parsetree.PPat (x0, x1) -> - Ast_411.Parsetree.PPat - ((copy_pattern x0), (Option.map copy_expression x1)) -and copy_structure : - Ast_412.Parsetree.structure -> Ast_411.Parsetree.structure = - fun x -> List.map copy_structure_item x -and copy_structure_item : - Ast_412.Parsetree.structure_item -> Ast_411.Parsetree.structure_item = - fun - { Ast_412.Parsetree.pstr_desc = pstr_desc; - Ast_412.Parsetree.pstr_loc = pstr_loc } - -> - { - Ast_411.Parsetree.pstr_desc = (copy_structure_item_desc pstr_desc); - Ast_411.Parsetree.pstr_loc = (copy_location pstr_loc) - } -and copy_structure_item_desc : - Ast_412.Parsetree.structure_item_desc -> - Ast_411.Parsetree.structure_item_desc - = - function - | Ast_412.Parsetree.Pstr_eval (x0, x1) -> - Ast_411.Parsetree.Pstr_eval - ((copy_expression x0), (copy_attributes x1)) - | Ast_412.Parsetree.Pstr_value (x0, x1) -> - Ast_411.Parsetree.Pstr_value - ((copy_rec_flag x0), (List.map copy_value_binding x1)) - | Ast_412.Parsetree.Pstr_primitive x0 -> - Ast_411.Parsetree.Pstr_primitive (copy_value_description x0) - | Ast_412.Parsetree.Pstr_type (x0, x1) -> - Ast_411.Parsetree.Pstr_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_412.Parsetree.Pstr_typext x0 -> - Ast_411.Parsetree.Pstr_typext (copy_type_extension x0) - | Ast_412.Parsetree.Pstr_exception x0 -> - Ast_411.Parsetree.Pstr_exception (copy_type_exception x0) - | Ast_412.Parsetree.Pstr_module x0 -> - Ast_411.Parsetree.Pstr_module (copy_module_binding x0) - | Ast_412.Parsetree.Pstr_recmodule x0 -> - Ast_411.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) - | Ast_412.Parsetree.Pstr_modtype x0 -> - Ast_411.Parsetree.Pstr_modtype (copy_module_type_declaration x0) - | Ast_412.Parsetree.Pstr_open x0 -> - Ast_411.Parsetree.Pstr_open (copy_open_declaration x0) - | Ast_412.Parsetree.Pstr_class x0 -> - Ast_411.Parsetree.Pstr_class (List.map copy_class_declaration x0) - | Ast_412.Parsetree.Pstr_class_type x0 -> - Ast_411.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | Ast_412.Parsetree.Pstr_include x0 -> - Ast_411.Parsetree.Pstr_include (copy_include_declaration x0) - | Ast_412.Parsetree.Pstr_attribute x0 -> - Ast_411.Parsetree.Pstr_attribute (copy_attribute x0) - | Ast_412.Parsetree.Pstr_extension (x0, x1) -> - Ast_411.Parsetree.Pstr_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_include_declaration : - Ast_412.Parsetree.include_declaration -> - Ast_411.Parsetree.include_declaration - = fun x -> copy_include_infos copy_module_expr x -and copy_class_declaration : - Ast_412.Parsetree.class_declaration -> Ast_411.Parsetree.class_declaration - = fun x -> copy_class_infos copy_class_expr x -and copy_class_expr : - Ast_412.Parsetree.class_expr -> Ast_411.Parsetree.class_expr = - fun - { Ast_412.Parsetree.pcl_desc = pcl_desc; - Ast_412.Parsetree.pcl_loc = pcl_loc; - Ast_412.Parsetree.pcl_attributes = pcl_attributes } - -> - { - Ast_411.Parsetree.pcl_desc = (copy_class_expr_desc pcl_desc); - Ast_411.Parsetree.pcl_loc = (copy_location pcl_loc); - Ast_411.Parsetree.pcl_attributes = (copy_attributes pcl_attributes) - } -and copy_class_expr_desc : - Ast_412.Parsetree.class_expr_desc -> Ast_411.Parsetree.class_expr_desc = - function - | Ast_412.Parsetree.Pcl_constr (x0, x1) -> - Ast_411.Parsetree.Pcl_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_412.Parsetree.Pcl_structure x0 -> - Ast_411.Parsetree.Pcl_structure (copy_class_structure x0) - | Ast_412.Parsetree.Pcl_fun (x0, x1, x2, x3) -> - Ast_411.Parsetree.Pcl_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_class_expr x3)) - | Ast_412.Parsetree.Pcl_apply (x0, x1) -> - Ast_411.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_412.Parsetree.Pcl_let (x0, x1, x2) -> - Ast_411.Parsetree.Pcl_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_class_expr x2)) - | Ast_412.Parsetree.Pcl_constraint (x0, x1) -> - Ast_411.Parsetree.Pcl_constraint - ((copy_class_expr x0), (copy_class_type x1)) - | Ast_412.Parsetree.Pcl_extension x0 -> - Ast_411.Parsetree.Pcl_extension (copy_extension x0) - | Ast_412.Parsetree.Pcl_open (x0, x1) -> - Ast_411.Parsetree.Pcl_open - ((copy_open_description x0), (copy_class_expr x1)) -and copy_class_structure : - Ast_412.Parsetree.class_structure -> Ast_411.Parsetree.class_structure = - fun - { Ast_412.Parsetree.pcstr_self = pcstr_self; - Ast_412.Parsetree.pcstr_fields = pcstr_fields } - -> - { - Ast_411.Parsetree.pcstr_self = (copy_pattern pcstr_self); - Ast_411.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } -and copy_class_field : - Ast_412.Parsetree.class_field -> Ast_411.Parsetree.class_field = - fun - { Ast_412.Parsetree.pcf_desc = pcf_desc; - Ast_412.Parsetree.pcf_loc = pcf_loc; - Ast_412.Parsetree.pcf_attributes = pcf_attributes } - -> - { - Ast_411.Parsetree.pcf_desc = (copy_class_field_desc pcf_desc); - Ast_411.Parsetree.pcf_loc = (copy_location pcf_loc); - Ast_411.Parsetree.pcf_attributes = (copy_attributes pcf_attributes) - } -and copy_class_field_desc : - Ast_412.Parsetree.class_field_desc -> Ast_411.Parsetree.class_field_desc = - function - | Ast_412.Parsetree.Pcf_inherit (x0, x1, x2) -> - Ast_411.Parsetree.Pcf_inherit - ((copy_override_flag x0), (copy_class_expr x1), - (Option.map (fun x -> copy_loc (fun x -> x) x) x2)) - | Ast_412.Parsetree.Pcf_val x0 -> - Ast_411.Parsetree.Pcf_val - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | Ast_412.Parsetree.Pcf_method x0 -> - Ast_411.Parsetree.Pcf_method - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_class_field_kind x2))) - | Ast_412.Parsetree.Pcf_constraint x0 -> - Ast_411.Parsetree.Pcf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_412.Parsetree.Pcf_initializer x0 -> - Ast_411.Parsetree.Pcf_initializer (copy_expression x0) - | Ast_412.Parsetree.Pcf_attribute x0 -> - Ast_411.Parsetree.Pcf_attribute (copy_attribute x0) - | Ast_412.Parsetree.Pcf_extension x0 -> - Ast_411.Parsetree.Pcf_extension (copy_extension x0) -and copy_class_field_kind : - Ast_412.Parsetree.class_field_kind -> Ast_411.Parsetree.class_field_kind = - function - | Ast_412.Parsetree.Cfk_virtual x0 -> - Ast_411.Parsetree.Cfk_virtual (copy_core_type x0) - | Ast_412.Parsetree.Cfk_concrete (x0, x1) -> - Ast_411.Parsetree.Cfk_concrete - ((copy_override_flag x0), (copy_expression x1)) -and copy_open_declaration : - Ast_412.Parsetree.open_declaration -> Ast_411.Parsetree.open_declaration = - fun x -> copy_open_infos copy_module_expr x -and copy_module_binding : - Ast_412.Parsetree.module_binding -> Ast_411.Parsetree.module_binding = - fun - { Ast_412.Parsetree.pmb_name = pmb_name; - Ast_412.Parsetree.pmb_expr = pmb_expr; - Ast_412.Parsetree.pmb_attributes = pmb_attributes; - Ast_412.Parsetree.pmb_loc = pmb_loc } - -> - { - Ast_411.Parsetree.pmb_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name); - Ast_411.Parsetree.pmb_expr = (copy_module_expr pmb_expr); - Ast_411.Parsetree.pmb_attributes = (copy_attributes pmb_attributes); - Ast_411.Parsetree.pmb_loc = (copy_location pmb_loc) - } -and copy_module_expr : - Ast_412.Parsetree.module_expr -> Ast_411.Parsetree.module_expr = - fun - { Ast_412.Parsetree.pmod_desc = pmod_desc; - Ast_412.Parsetree.pmod_loc = pmod_loc; - Ast_412.Parsetree.pmod_attributes = pmod_attributes } - -> - { - Ast_411.Parsetree.pmod_desc = (copy_module_expr_desc pmod_desc); - Ast_411.Parsetree.pmod_loc = (copy_location pmod_loc); - Ast_411.Parsetree.pmod_attributes = (copy_attributes pmod_attributes) - } -and copy_module_expr_desc : - Ast_412.Parsetree.module_expr_desc -> Ast_411.Parsetree.module_expr_desc = - function - | Ast_412.Parsetree.Pmod_ident x0 -> - Ast_411.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) - | Ast_412.Parsetree.Pmod_structure x0 -> - Ast_411.Parsetree.Pmod_structure (copy_structure x0) - | Ast_412.Parsetree.Pmod_functor (x0, x1) -> - Ast_411.Parsetree.Pmod_functor - ((copy_functor_parameter x0), (copy_module_expr x1)) - | Ast_412.Parsetree.Pmod_apply (x0, x1) -> - Ast_411.Parsetree.Pmod_apply - ((copy_module_expr x0), (copy_module_expr x1)) - | Ast_412.Parsetree.Pmod_constraint (x0, x1) -> - Ast_411.Parsetree.Pmod_constraint - ((copy_module_expr x0), (copy_module_type x1)) - | Ast_412.Parsetree.Pmod_unpack x0 -> - Ast_411.Parsetree.Pmod_unpack (copy_expression x0) - | Ast_412.Parsetree.Pmod_extension x0 -> - Ast_411.Parsetree.Pmod_extension (copy_extension x0) -and copy_functor_parameter : - Ast_412.Parsetree.functor_parameter -> Ast_411.Parsetree.functor_parameter - = - function - | Ast_412.Parsetree.Unit -> Ast_411.Parsetree.Unit - | Ast_412.Parsetree.Named (x0, x1) -> - Ast_411.Parsetree.Named - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_type x1)) -and copy_module_type : - Ast_412.Parsetree.module_type -> Ast_411.Parsetree.module_type = - fun - { Ast_412.Parsetree.pmty_desc = pmty_desc; - Ast_412.Parsetree.pmty_loc = pmty_loc; - Ast_412.Parsetree.pmty_attributes = pmty_attributes } - -> - { - Ast_411.Parsetree.pmty_desc = (copy_module_type_desc pmty_desc); - Ast_411.Parsetree.pmty_loc = (copy_location pmty_loc); - Ast_411.Parsetree.pmty_attributes = (copy_attributes pmty_attributes) - } -and copy_module_type_desc : - Ast_412.Parsetree.module_type_desc -> Ast_411.Parsetree.module_type_desc = - function - | Ast_412.Parsetree.Pmty_ident x0 -> - Ast_411.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) - | Ast_412.Parsetree.Pmty_signature x0 -> - Ast_411.Parsetree.Pmty_signature (copy_signature x0) - | Ast_412.Parsetree.Pmty_functor (x0, x1) -> - Ast_411.Parsetree.Pmty_functor - ((copy_functor_parameter x0), (copy_module_type x1)) - | Ast_412.Parsetree.Pmty_with (x0, x1) -> - Ast_411.Parsetree.Pmty_with - ((copy_module_type x0), (List.map copy_with_constraint x1)) - | Ast_412.Parsetree.Pmty_typeof x0 -> - Ast_411.Parsetree.Pmty_typeof (copy_module_expr x0) - | Ast_412.Parsetree.Pmty_extension x0 -> - Ast_411.Parsetree.Pmty_extension (copy_extension x0) - | Ast_412.Parsetree.Pmty_alias x0 -> - Ast_411.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) -and copy_with_constraint : - Ast_412.Parsetree.with_constraint -> Ast_411.Parsetree.with_constraint = - function - | Ast_412.Parsetree.Pwith_type (x0, x1) -> - Ast_411.Parsetree.Pwith_type - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_412.Parsetree.Pwith_module (x0, x1) -> - Ast_411.Parsetree.Pwith_module - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) - | Ast_412.Parsetree.Pwith_typesubst (x0, x1) -> - Ast_411.Parsetree.Pwith_typesubst - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_412.Parsetree.Pwith_modsubst (x0, x1) -> - Ast_411.Parsetree.Pwith_modsubst - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) -and copy_signature : - Ast_412.Parsetree.signature -> Ast_411.Parsetree.signature = - fun x -> List.map copy_signature_item x -and copy_signature_item : - Ast_412.Parsetree.signature_item -> Ast_411.Parsetree.signature_item = - fun - { Ast_412.Parsetree.psig_desc = psig_desc; - Ast_412.Parsetree.psig_loc = psig_loc } - -> - { - Ast_411.Parsetree.psig_desc = (copy_signature_item_desc psig_desc); - Ast_411.Parsetree.psig_loc = (copy_location psig_loc) - } -and copy_signature_item_desc : - Ast_412.Parsetree.signature_item_desc -> - Ast_411.Parsetree.signature_item_desc - = - function - | Ast_412.Parsetree.Psig_value x0 -> - Ast_411.Parsetree.Psig_value (copy_value_description x0) - | Ast_412.Parsetree.Psig_type (x0, x1) -> - Ast_411.Parsetree.Psig_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_412.Parsetree.Psig_typesubst x0 -> - Ast_411.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) - | Ast_412.Parsetree.Psig_typext x0 -> - Ast_411.Parsetree.Psig_typext (copy_type_extension x0) - | Ast_412.Parsetree.Psig_exception x0 -> - Ast_411.Parsetree.Psig_exception (copy_type_exception x0) - | Ast_412.Parsetree.Psig_module x0 -> - Ast_411.Parsetree.Psig_module (copy_module_declaration x0) - | Ast_412.Parsetree.Psig_modsubst x0 -> - Ast_411.Parsetree.Psig_modsubst (copy_module_substitution x0) - | Ast_412.Parsetree.Psig_recmodule x0 -> - Ast_411.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) - | Ast_412.Parsetree.Psig_modtype x0 -> - Ast_411.Parsetree.Psig_modtype (copy_module_type_declaration x0) - | Ast_412.Parsetree.Psig_open x0 -> - Ast_411.Parsetree.Psig_open (copy_open_description x0) - | Ast_412.Parsetree.Psig_include x0 -> - Ast_411.Parsetree.Psig_include (copy_include_description x0) - | Ast_412.Parsetree.Psig_class x0 -> - Ast_411.Parsetree.Psig_class (List.map copy_class_description x0) - | Ast_412.Parsetree.Psig_class_type x0 -> - Ast_411.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | Ast_412.Parsetree.Psig_attribute x0 -> - Ast_411.Parsetree.Psig_attribute (copy_attribute x0) - | Ast_412.Parsetree.Psig_extension (x0, x1) -> - Ast_411.Parsetree.Psig_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_class_type_declaration : - Ast_412.Parsetree.class_type_declaration -> - Ast_411.Parsetree.class_type_declaration - = fun x -> copy_class_infos copy_class_type x -and copy_class_description : - Ast_412.Parsetree.class_description -> Ast_411.Parsetree.class_description - = fun x -> copy_class_infos copy_class_type x -and copy_class_type : - Ast_412.Parsetree.class_type -> Ast_411.Parsetree.class_type = - fun - { Ast_412.Parsetree.pcty_desc = pcty_desc; - Ast_412.Parsetree.pcty_loc = pcty_loc; - Ast_412.Parsetree.pcty_attributes = pcty_attributes } - -> - { - Ast_411.Parsetree.pcty_desc = (copy_class_type_desc pcty_desc); - Ast_411.Parsetree.pcty_loc = (copy_location pcty_loc); - Ast_411.Parsetree.pcty_attributes = (copy_attributes pcty_attributes) - } -and copy_class_type_desc : - Ast_412.Parsetree.class_type_desc -> Ast_411.Parsetree.class_type_desc = - function - | Ast_412.Parsetree.Pcty_constr (x0, x1) -> - Ast_411.Parsetree.Pcty_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_412.Parsetree.Pcty_signature x0 -> - Ast_411.Parsetree.Pcty_signature (copy_class_signature x0) - | Ast_412.Parsetree.Pcty_arrow (x0, x1, x2) -> - Ast_411.Parsetree.Pcty_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_class_type x2)) - | Ast_412.Parsetree.Pcty_extension x0 -> - Ast_411.Parsetree.Pcty_extension (copy_extension x0) - | Ast_412.Parsetree.Pcty_open (x0, x1) -> - Ast_411.Parsetree.Pcty_open - ((copy_open_description x0), (copy_class_type x1)) -and copy_class_signature : - Ast_412.Parsetree.class_signature -> Ast_411.Parsetree.class_signature = - fun - { Ast_412.Parsetree.pcsig_self = pcsig_self; - Ast_412.Parsetree.pcsig_fields = pcsig_fields } - -> - { - Ast_411.Parsetree.pcsig_self = (copy_core_type pcsig_self); - Ast_411.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } -and copy_class_type_field : - Ast_412.Parsetree.class_type_field -> Ast_411.Parsetree.class_type_field = - fun - { Ast_412.Parsetree.pctf_desc = pctf_desc; - Ast_412.Parsetree.pctf_loc = pctf_loc; - Ast_412.Parsetree.pctf_attributes = pctf_attributes } - -> - { - Ast_411.Parsetree.pctf_desc = (copy_class_type_field_desc pctf_desc); - Ast_411.Parsetree.pctf_loc = (copy_location pctf_loc); - Ast_411.Parsetree.pctf_attributes = (copy_attributes pctf_attributes) - } -and copy_class_type_field_desc : - Ast_412.Parsetree.class_type_field_desc -> - Ast_411.Parsetree.class_type_field_desc - = - function - | Ast_412.Parsetree.Pctf_inherit x0 -> - Ast_411.Parsetree.Pctf_inherit (copy_class_type x0) - | Ast_412.Parsetree.Pctf_val x0 -> - Ast_411.Parsetree.Pctf_val - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_412.Parsetree.Pctf_method x0 -> - Ast_411.Parsetree.Pctf_method - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_412.Parsetree.Pctf_constraint x0 -> - Ast_411.Parsetree.Pctf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_412.Parsetree.Pctf_attribute x0 -> - Ast_411.Parsetree.Pctf_attribute (copy_attribute x0) - | Ast_412.Parsetree.Pctf_extension x0 -> - Ast_411.Parsetree.Pctf_extension (copy_extension x0) -and copy_extension : - Ast_412.Parsetree.extension -> Ast_411.Parsetree.extension = - fun x -> - let (x0, x1) = x in ((copy_loc (fun x -> x) x0), (copy_payload x1)) -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_412.Parsetree.class_infos -> 'g0 Ast_411.Parsetree.class_infos - = - fun f0 -> - fun - { Ast_412.Parsetree.pci_virt = pci_virt; - Ast_412.Parsetree.pci_params = pci_params; - Ast_412.Parsetree.pci_name = pci_name; - Ast_412.Parsetree.pci_expr = pci_expr; - Ast_412.Parsetree.pci_loc = pci_loc; - Ast_412.Parsetree.pci_attributes = pci_attributes } - -> - { - Ast_411.Parsetree.pci_virt = (copy_virtual_flag pci_virt); - Ast_411.Parsetree.pci_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, _) = x1 in - (copy_variance x0)))) pci_params); - Ast_411.Parsetree.pci_name = (copy_loc (fun x -> x) pci_name); - Ast_411.Parsetree.pci_expr = (f0 pci_expr); - Ast_411.Parsetree.pci_loc = (copy_location pci_loc); - Ast_411.Parsetree.pci_attributes = (copy_attributes pci_attributes) - } -and copy_virtual_flag : - Ast_412.Asttypes.virtual_flag -> Ast_411.Asttypes.virtual_flag = - function - | Ast_412.Asttypes.Virtual -> Ast_411.Asttypes.Virtual - | Ast_412.Asttypes.Concrete -> Ast_411.Asttypes.Concrete -and copy_include_description : - Ast_412.Parsetree.include_description -> - Ast_411.Parsetree.include_description - = fun x -> copy_include_infos copy_module_type x -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_412.Parsetree.include_infos -> - 'g0 Ast_411.Parsetree.include_infos - = - fun f0 -> - fun - { Ast_412.Parsetree.pincl_mod = pincl_mod; - Ast_412.Parsetree.pincl_loc = pincl_loc; - Ast_412.Parsetree.pincl_attributes = pincl_attributes } - -> - { - Ast_411.Parsetree.pincl_mod = (f0 pincl_mod); - Ast_411.Parsetree.pincl_loc = (copy_location pincl_loc); - Ast_411.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } -and copy_open_description : - Ast_412.Parsetree.open_description -> Ast_411.Parsetree.open_description = - fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x -and copy_open_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_412.Parsetree.open_infos -> 'g0 Ast_411.Parsetree.open_infos - = - fun f0 -> - fun - { Ast_412.Parsetree.popen_expr = popen_expr; - Ast_412.Parsetree.popen_override = popen_override; - Ast_412.Parsetree.popen_loc = popen_loc; - Ast_412.Parsetree.popen_attributes = popen_attributes } - -> - { - Ast_411.Parsetree.popen_expr = (f0 popen_expr); - Ast_411.Parsetree.popen_override = - (copy_override_flag popen_override); - Ast_411.Parsetree.popen_loc = (copy_location popen_loc); - Ast_411.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } -and copy_override_flag : - Ast_412.Asttypes.override_flag -> Ast_411.Asttypes.override_flag = - function - | Ast_412.Asttypes.Override -> Ast_411.Asttypes.Override - | Ast_412.Asttypes.Fresh -> Ast_411.Asttypes.Fresh -and copy_module_type_declaration : - Ast_412.Parsetree.module_type_declaration -> - Ast_411.Parsetree.module_type_declaration - = - fun - { Ast_412.Parsetree.pmtd_name = pmtd_name; - Ast_412.Parsetree.pmtd_type = pmtd_type; - Ast_412.Parsetree.pmtd_attributes = pmtd_attributes; - Ast_412.Parsetree.pmtd_loc = pmtd_loc } - -> - { - Ast_411.Parsetree.pmtd_name = (copy_loc (fun x -> x) pmtd_name); - Ast_411.Parsetree.pmtd_type = (Option.map copy_module_type pmtd_type); - Ast_411.Parsetree.pmtd_attributes = (copy_attributes pmtd_attributes); - Ast_411.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } -and copy_module_substitution : - Ast_412.Parsetree.module_substitution -> - Ast_411.Parsetree.module_substitution - = - fun - { Ast_412.Parsetree.pms_name = pms_name; - Ast_412.Parsetree.pms_manifest = pms_manifest; - Ast_412.Parsetree.pms_attributes = pms_attributes; - Ast_412.Parsetree.pms_loc = pms_loc } - -> - { - Ast_411.Parsetree.pms_name = (copy_loc (fun x -> x) pms_name); - Ast_411.Parsetree.pms_manifest = - (copy_loc copy_Longident_t pms_manifest); - Ast_411.Parsetree.pms_attributes = (copy_attributes pms_attributes); - Ast_411.Parsetree.pms_loc = (copy_location pms_loc) - } -and copy_module_declaration : - Ast_412.Parsetree.module_declaration -> - Ast_411.Parsetree.module_declaration - = - fun - { Ast_412.Parsetree.pmd_name = pmd_name; - Ast_412.Parsetree.pmd_type = pmd_type; - Ast_412.Parsetree.pmd_attributes = pmd_attributes; - Ast_412.Parsetree.pmd_loc = pmd_loc } - -> - { - Ast_411.Parsetree.pmd_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name); - Ast_411.Parsetree.pmd_type = (copy_module_type pmd_type); - Ast_411.Parsetree.pmd_attributes = (copy_attributes pmd_attributes); - Ast_411.Parsetree.pmd_loc = (copy_location pmd_loc) - } -and copy_type_exception : - Ast_412.Parsetree.type_exception -> Ast_411.Parsetree.type_exception = - fun - { Ast_412.Parsetree.ptyexn_constructor = ptyexn_constructor; - Ast_412.Parsetree.ptyexn_loc = ptyexn_loc; - Ast_412.Parsetree.ptyexn_attributes = ptyexn_attributes } - -> - { - Ast_411.Parsetree.ptyexn_constructor = - (copy_extension_constructor ptyexn_constructor); - Ast_411.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); - Ast_411.Parsetree.ptyexn_attributes = - (copy_attributes ptyexn_attributes) - } -and copy_type_extension : - Ast_412.Parsetree.type_extension -> Ast_411.Parsetree.type_extension = - fun - { Ast_412.Parsetree.ptyext_path = ptyext_path; - Ast_412.Parsetree.ptyext_params = ptyext_params; - Ast_412.Parsetree.ptyext_constructors = ptyext_constructors; - Ast_412.Parsetree.ptyext_private = ptyext_private; - Ast_412.Parsetree.ptyext_loc = ptyext_loc; - Ast_412.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - Ast_411.Parsetree.ptyext_path = (copy_loc copy_Longident_t ptyext_path); - Ast_411.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, _) = x1 in - (copy_variance x0)))) ptyext_params); - Ast_411.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor ptyext_constructors); - Ast_411.Parsetree.ptyext_private = (copy_private_flag ptyext_private); - Ast_411.Parsetree.ptyext_loc = (copy_location ptyext_loc); - Ast_411.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } -and copy_extension_constructor : - Ast_412.Parsetree.extension_constructor -> - Ast_411.Parsetree.extension_constructor - = - fun - { Ast_412.Parsetree.pext_name = pext_name; - Ast_412.Parsetree.pext_kind = pext_kind; - Ast_412.Parsetree.pext_loc = pext_loc; - Ast_412.Parsetree.pext_attributes = pext_attributes } - -> - { - Ast_411.Parsetree.pext_name = (copy_loc (fun x -> x) pext_name); - Ast_411.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - Ast_411.Parsetree.pext_loc = (copy_location pext_loc); - Ast_411.Parsetree.pext_attributes = (copy_attributes pext_attributes) - } -and copy_extension_constructor_kind : - Ast_412.Parsetree.extension_constructor_kind -> - Ast_411.Parsetree.extension_constructor_kind - = - function - | Ast_412.Parsetree.Pext_decl (x0, x1) -> - Ast_411.Parsetree.Pext_decl - ((copy_constructor_arguments x0), (Option.map copy_core_type x1)) - | Ast_412.Parsetree.Pext_rebind x0 -> - Ast_411.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) -and copy_type_declaration : - Ast_412.Parsetree.type_declaration -> Ast_411.Parsetree.type_declaration = - fun - { Ast_412.Parsetree.ptype_name = ptype_name; - Ast_412.Parsetree.ptype_params = ptype_params; - Ast_412.Parsetree.ptype_cstrs = ptype_cstrs; - Ast_412.Parsetree.ptype_kind = ptype_kind; - Ast_412.Parsetree.ptype_private = ptype_private; - Ast_412.Parsetree.ptype_manifest = ptype_manifest; - Ast_412.Parsetree.ptype_attributes = ptype_attributes; - Ast_412.Parsetree.ptype_loc = ptype_loc } - -> - { - Ast_411.Parsetree.ptype_name = (copy_loc (fun x -> x) ptype_name); - Ast_411.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, _) = x1 in - (copy_variance x0)))) ptype_params); - Ast_411.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0, x1, x2) = x in - ((copy_core_type x0), (copy_core_type x1), (copy_location x2))) - ptype_cstrs); - Ast_411.Parsetree.ptype_kind = (copy_type_kind ptype_kind); - Ast_411.Parsetree.ptype_private = (copy_private_flag ptype_private); - Ast_411.Parsetree.ptype_manifest = - (Option.map copy_core_type ptype_manifest); - Ast_411.Parsetree.ptype_attributes = (copy_attributes ptype_attributes); - Ast_411.Parsetree.ptype_loc = (copy_location ptype_loc) - } -and copy_private_flag : - Ast_412.Asttypes.private_flag -> Ast_411.Asttypes.private_flag = - function - | Ast_412.Asttypes.Private -> Ast_411.Asttypes.Private - | Ast_412.Asttypes.Public -> Ast_411.Asttypes.Public -and copy_type_kind : - Ast_412.Parsetree.type_kind -> Ast_411.Parsetree.type_kind = - function - | Ast_412.Parsetree.Ptype_abstract -> Ast_411.Parsetree.Ptype_abstract - | Ast_412.Parsetree.Ptype_variant x0 -> - Ast_411.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | Ast_412.Parsetree.Ptype_record x0 -> - Ast_411.Parsetree.Ptype_record (List.map copy_label_declaration x0) - | Ast_412.Parsetree.Ptype_open -> Ast_411.Parsetree.Ptype_open -and copy_constructor_declaration : - Ast_412.Parsetree.constructor_declaration -> - Ast_411.Parsetree.constructor_declaration - = - fun - { Ast_412.Parsetree.pcd_name = pcd_name; - Ast_412.Parsetree.pcd_args = pcd_args; - Ast_412.Parsetree.pcd_res = pcd_res; - Ast_412.Parsetree.pcd_loc = pcd_loc; - Ast_412.Parsetree.pcd_attributes = pcd_attributes } - -> - { - Ast_411.Parsetree.pcd_name = (copy_loc (fun x -> x) pcd_name); - Ast_411.Parsetree.pcd_args = (copy_constructor_arguments pcd_args); - Ast_411.Parsetree.pcd_res = (Option.map copy_core_type pcd_res); - Ast_411.Parsetree.pcd_loc = (copy_location pcd_loc); - Ast_411.Parsetree.pcd_attributes = (copy_attributes pcd_attributes) - } -and copy_constructor_arguments : - Ast_412.Parsetree.constructor_arguments -> - Ast_411.Parsetree.constructor_arguments - = - function - | Ast_412.Parsetree.Pcstr_tuple x0 -> - Ast_411.Parsetree.Pcstr_tuple (List.map copy_core_type x0) - | Ast_412.Parsetree.Pcstr_record x0 -> - Ast_411.Parsetree.Pcstr_record (List.map copy_label_declaration x0) -and copy_label_declaration : - Ast_412.Parsetree.label_declaration -> Ast_411.Parsetree.label_declaration - = - fun - { Ast_412.Parsetree.pld_name = pld_name; - Ast_412.Parsetree.pld_mutable = pld_mutable; - Ast_412.Parsetree.pld_type = pld_type; - Ast_412.Parsetree.pld_loc = pld_loc; - Ast_412.Parsetree.pld_attributes = pld_attributes } - -> - { - Ast_411.Parsetree.pld_name = (copy_loc (fun x -> x) pld_name); - Ast_411.Parsetree.pld_mutable = (copy_mutable_flag pld_mutable); - Ast_411.Parsetree.pld_type = (copy_core_type pld_type); - Ast_411.Parsetree.pld_loc = (copy_location pld_loc); - Ast_411.Parsetree.pld_attributes = (copy_attributes pld_attributes) - } -and copy_mutable_flag : - Ast_412.Asttypes.mutable_flag -> Ast_411.Asttypes.mutable_flag = - function - | Ast_412.Asttypes.Immutable -> Ast_411.Asttypes.Immutable - | Ast_412.Asttypes.Mutable -> Ast_411.Asttypes.Mutable -and copy_variance : Ast_412.Asttypes.variance -> Ast_411.Asttypes.variance = - function - | Ast_412.Asttypes.Covariant -> Ast_411.Asttypes.Covariant - | Ast_412.Asttypes.Contravariant -> Ast_411.Asttypes.Contravariant - | Ast_412.Asttypes.NoVariance -> Ast_411.Asttypes.Invariant -and copy_value_description : - Ast_412.Parsetree.value_description -> Ast_411.Parsetree.value_description - = - fun - { Ast_412.Parsetree.pval_name = pval_name; - Ast_412.Parsetree.pval_type = pval_type; - Ast_412.Parsetree.pval_prim = pval_prim; - Ast_412.Parsetree.pval_attributes = pval_attributes; - Ast_412.Parsetree.pval_loc = pval_loc } - -> - { - Ast_411.Parsetree.pval_name = (copy_loc (fun x -> x) pval_name); - Ast_411.Parsetree.pval_type = (copy_core_type pval_type); - Ast_411.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - Ast_411.Parsetree.pval_attributes = (copy_attributes pval_attributes); - Ast_411.Parsetree.pval_loc = (copy_location pval_loc) - } -and copy_object_field_desc : - Ast_412.Parsetree.object_field_desc -> Ast_411.Parsetree.object_field_desc - = - function - | Ast_412.Parsetree.Otag (x0, x1) -> - Ast_411.Parsetree.Otag ((copy_loc copy_label x0), (copy_core_type x1)) - | Ast_412.Parsetree.Oinherit x0 -> - Ast_411.Parsetree.Oinherit (copy_core_type x0) -and copy_arg_label : Ast_412.Asttypes.arg_label -> Ast_411.Asttypes.arg_label - = - function - | Ast_412.Asttypes.Nolabel -> Ast_411.Asttypes.Nolabel - | Ast_412.Asttypes.Labelled x0 -> Ast_411.Asttypes.Labelled x0 - | Ast_412.Asttypes.Optional x0 -> Ast_411.Asttypes.Optional x0 -and copy_closed_flag : - Ast_412.Asttypes.closed_flag -> Ast_411.Asttypes.closed_flag = - function - | Ast_412.Asttypes.Closed -> Ast_411.Asttypes.Closed - | Ast_412.Asttypes.Open -> Ast_411.Asttypes.Open -and copy_label : Ast_412.Asttypes.label -> Ast_411.Asttypes.label = - fun x -> x -and copy_rec_flag : Ast_412.Asttypes.rec_flag -> Ast_411.Asttypes.rec_flag = - function - | Ast_412.Asttypes.Nonrecursive -> Ast_411.Asttypes.Nonrecursive - | Ast_412.Asttypes.Recursive -> Ast_411.Asttypes.Recursive -and copy_constant : Ast_412.Parsetree.constant -> Ast_411.Parsetree.constant - = - function - | Ast_412.Parsetree.Pconst_integer (x0, x1) -> - Ast_411.Parsetree.Pconst_integer (x0, (Option.map (fun x -> x) x1)) - | Ast_412.Parsetree.Pconst_char x0 -> Ast_411.Parsetree.Pconst_char x0 - | Ast_412.Parsetree.Pconst_string (x0, x1, x2) -> - Ast_411.Parsetree.Pconst_string - (x0, (copy_location x1), (Option.map (fun x -> x) x2)) - | Ast_412.Parsetree.Pconst_float (x0, x1) -> - Ast_411.Parsetree.Pconst_float (x0, (Option.map (fun x -> x) x1)) -and copy_Longident_t : Longident.t -> Longident.t = - function - | Longident.Lident x0 -> Longident.Lident x0 - | Longident.Ldot (x0, x1) -> Longident.Ldot ((copy_Longident_t x0), x1) - | Longident.Lapply (x0, x1) -> - Longident.Lapply ((copy_Longident_t x0), (copy_Longident_t x1)) -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 Ast_412.Asttypes.loc -> 'g0 Ast_411.Asttypes.loc - = - fun f0 -> - fun { Ast_412.Asttypes.txt = txt; Ast_412.Asttypes.loc = loc } -> - { - Ast_411.Asttypes.txt = (f0 txt); - Ast_411.Asttypes.loc = (copy_location loc) - } -and copy_location : Location.t -> Location.t = - fun - { Location.loc_start = loc_start; Location.loc_end = loc_end; - Location.loc_ghost = loc_ghost } - -> - { - Location.loc_start = (copy_position loc_start); - Location.loc_end = (copy_position loc_end); - Location.loc_ghost = loc_ghost - } -and copy_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum - } - diff --git a/src/vendored-omp/src/migrate_parsetree_412_413.ml b/src/vendored-omp/src/migrate_parsetree_412_413.ml index e99fd3e1a..34a1d4ece 100644 --- a/src/vendored-omp/src/migrate_parsetree_412_413.ml +++ b/src/vendored-omp/src/migrate_parsetree_412_413.ml @@ -15,130 +15,3 @@ include Migrate_parsetree_412_413_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload"; - "binding_op"; "module_substitution"; "open_declaration"; "type_exception"; - "constant" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - binding_op; - module_substitution; - open_declaration; - type_exception; - constant; - (*$*) - } as mapper) -> - let module Def = Migrate_parsetree_def in - let module R = Migrate_parsetree_413_412_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> List.map copy_case (cases mapper (List.map R.copy_case x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expression (expr mapper (R.copy_expression x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pattern (pat mapper (R.copy_pattern x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_core_type (typ mapper (R.copy_core_type x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - binding_op = (fun _ x -> copy_binding_op (binding_op mapper (R.copy_binding_op x))); - module_substitution = (fun _ x -> copy_module_substitution (module_substitution mapper (R.copy_module_substitution x))); - open_declaration = (fun _ x -> copy_open_declaration (open_declaration mapper (R.copy_open_declaration x))); - type_exception = (fun _ x -> copy_type_exception (type_exception mapper (R.copy_type_exception x))); - constant = (fun _ x -> copy_constant (constant mapper (R.copy_constant x))); - (*$*) - } - diff --git a/src/vendored-omp/src/migrate_parsetree_412_413_migrate.ml b/src/vendored-omp/src/migrate_parsetree_412_413_migrate.ml index 22dc56b4f..7be021df7 100644 --- a/src/vendored-omp/src/migrate_parsetree_412_413_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_412_413_migrate.ml @@ -156,6 +156,11 @@ and copy_out_extension_constructor : (Option.map copy_out_type oext_ret_type); Ast_413.Outcometree.oext_private = (copy_private_flag oext_private) } +and copy_private_flag : + Ast_412.Asttypes.private_flag -> Ast_413.Asttypes.private_flag = + function + | Ast_412.Asttypes.Private -> Ast_413.Asttypes.Private + | Ast_412.Asttypes.Public -> Ast_413.Asttypes.Public and copy_out_rec_status : Ast_412.Outcometree.out_rec_status -> Ast_413.Outcometree.out_rec_status = function @@ -192,6 +197,16 @@ and copy_out_type_param : fun x -> let (x0, x1) = x in (x0, (let (x0, x1) = x1 in ((copy_variance x0), (copy_injectivity x1)))) +and copy_injectivity : + Ast_412.Asttypes.injectivity -> Ast_413.Asttypes.injectivity = + function + | Ast_412.Asttypes.Injective -> Ast_413.Asttypes.Injective + | Ast_412.Asttypes.NoInjectivity -> Ast_413.Asttypes.NoInjectivity +and copy_variance : Ast_412.Asttypes.variance -> Ast_413.Asttypes.variance = + function + | Ast_412.Asttypes.Covariant -> Ast_413.Asttypes.Covariant + | Ast_412.Asttypes.Contravariant -> Ast_413.Asttypes.Contravariant + | Ast_412.Asttypes.NoVariance -> Ast_413.Asttypes.NoVariance and copy_out_type : Ast_412.Outcometree.out_type -> Ast_413.Outcometree.out_type = function @@ -311,1212 +326,3 @@ and copy_out_name : Ast_412.Outcometree.out_name -> Ast_413.Outcometree.out_name = fun { Ast_412.Outcometree.printed_name = printed_name } -> { Ast_413.Outcometree.printed_name = printed_name } -and copy_toplevel_phrase : - Ast_412.Parsetree.toplevel_phrase -> Ast_413.Parsetree.toplevel_phrase = - function - | Ast_412.Parsetree.Ptop_def x0 -> - Ast_413.Parsetree.Ptop_def (copy_structure x0) - | Ast_412.Parsetree.Ptop_dir x0 -> - Ast_413.Parsetree.Ptop_dir (copy_toplevel_directive x0) -and copy_toplevel_directive : - Ast_412.Parsetree.toplevel_directive -> - Ast_413.Parsetree.toplevel_directive - = - fun - { Ast_412.Parsetree.pdir_name = pdir_name; - Ast_412.Parsetree.pdir_arg = pdir_arg; - Ast_412.Parsetree.pdir_loc = pdir_loc } - -> - { - Ast_413.Parsetree.pdir_name = (copy_loc (fun x -> x) pdir_name); - Ast_413.Parsetree.pdir_arg = - (Option.map copy_directive_argument pdir_arg); - Ast_413.Parsetree.pdir_loc = (copy_location pdir_loc) - } -and copy_directive_argument : - Ast_412.Parsetree.directive_argument -> - Ast_413.Parsetree.directive_argument - = - fun - { Ast_412.Parsetree.pdira_desc = pdira_desc; - Ast_412.Parsetree.pdira_loc = pdira_loc } - -> - { - Ast_413.Parsetree.pdira_desc = - (copy_directive_argument_desc pdira_desc); - Ast_413.Parsetree.pdira_loc = (copy_location pdira_loc) - } -and copy_directive_argument_desc : - Ast_412.Parsetree.directive_argument_desc -> - Ast_413.Parsetree.directive_argument_desc - = - function - | Ast_412.Parsetree.Pdir_string x0 -> Ast_413.Parsetree.Pdir_string x0 - | Ast_412.Parsetree.Pdir_int (x0, x1) -> - Ast_413.Parsetree.Pdir_int (x0, (Option.map (fun x -> x) x1)) - | Ast_412.Parsetree.Pdir_ident x0 -> - Ast_413.Parsetree.Pdir_ident (copy_Longident_t x0) - | Ast_412.Parsetree.Pdir_bool x0 -> Ast_413.Parsetree.Pdir_bool x0 -and copy_expression : - Ast_412.Parsetree.expression -> Ast_413.Parsetree.expression = - fun - { Ast_412.Parsetree.pexp_desc = pexp_desc; - Ast_412.Parsetree.pexp_loc = pexp_loc; - Ast_412.Parsetree.pexp_loc_stack = pexp_loc_stack; - Ast_412.Parsetree.pexp_attributes = pexp_attributes } - -> - { - Ast_413.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - Ast_413.Parsetree.pexp_loc = (copy_location pexp_loc); - Ast_413.Parsetree.pexp_loc_stack = (copy_location_stack pexp_loc_stack); - Ast_413.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } -and copy_expression_desc : - Ast_412.Parsetree.expression_desc -> Ast_413.Parsetree.expression_desc = - function - | Ast_412.Parsetree.Pexp_ident x0 -> - Ast_413.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) - | Ast_412.Parsetree.Pexp_constant x0 -> - Ast_413.Parsetree.Pexp_constant (copy_constant x0) - | Ast_412.Parsetree.Pexp_let (x0, x1, x2) -> - Ast_413.Parsetree.Pexp_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_expression x2)) - | Ast_412.Parsetree.Pexp_function x0 -> - Ast_413.Parsetree.Pexp_function (List.map copy_case x0) - | Ast_412.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_413.Parsetree.Pexp_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_expression x3)) - | Ast_412.Parsetree.Pexp_apply (x0, x1) -> - Ast_413.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_412.Parsetree.Pexp_match (x0, x1) -> - Ast_413.Parsetree.Pexp_match - ((copy_expression x0), (List.map copy_case x1)) - | Ast_412.Parsetree.Pexp_try (x0, x1) -> - Ast_413.Parsetree.Pexp_try - ((copy_expression x0), (List.map copy_case x1)) - | Ast_412.Parsetree.Pexp_tuple x0 -> - Ast_413.Parsetree.Pexp_tuple (List.map copy_expression x0) - | Ast_412.Parsetree.Pexp_construct (x0, x1) -> - Ast_413.Parsetree.Pexp_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_expression x1)) - | Ast_412.Parsetree.Pexp_variant (x0, x1) -> - Ast_413.Parsetree.Pexp_variant - ((copy_label x0), (Option.map copy_expression x1)) - | Ast_412.Parsetree.Pexp_record (x0, x1) -> - Ast_413.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_expression x1))) x0), - (Option.map copy_expression x1)) - | Ast_412.Parsetree.Pexp_field (x0, x1) -> - Ast_413.Parsetree.Pexp_field - ((copy_expression x0), (copy_loc copy_Longident_t x1)) - | Ast_412.Parsetree.Pexp_setfield (x0, x1, x2) -> - Ast_413.Parsetree.Pexp_setfield - ((copy_expression x0), (copy_loc copy_Longident_t x1), - (copy_expression x2)) - | Ast_412.Parsetree.Pexp_array x0 -> - Ast_413.Parsetree.Pexp_array (List.map copy_expression x0) - | Ast_412.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> - Ast_413.Parsetree.Pexp_ifthenelse - ((copy_expression x0), (copy_expression x1), - (Option.map copy_expression x2)) - | Ast_412.Parsetree.Pexp_sequence (x0, x1) -> - Ast_413.Parsetree.Pexp_sequence - ((copy_expression x0), (copy_expression x1)) - | Ast_412.Parsetree.Pexp_while (x0, x1) -> - Ast_413.Parsetree.Pexp_while - ((copy_expression x0), (copy_expression x1)) - | Ast_412.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> - Ast_413.Parsetree.Pexp_for - ((copy_pattern x0), (copy_expression x1), (copy_expression x2), - (copy_direction_flag x3), (copy_expression x4)) - | Ast_412.Parsetree.Pexp_constraint (x0, x1) -> - Ast_413.Parsetree.Pexp_constraint - ((copy_expression x0), (copy_core_type x1)) - | Ast_412.Parsetree.Pexp_coerce (x0, x1, x2) -> - Ast_413.Parsetree.Pexp_coerce - ((copy_expression x0), (Option.map copy_core_type x1), - (copy_core_type x2)) - | Ast_412.Parsetree.Pexp_send (x0, x1) -> - Ast_413.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc copy_label x1)) - | Ast_412.Parsetree.Pexp_new x0 -> - Ast_413.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) - | Ast_412.Parsetree.Pexp_setinstvar (x0, x1) -> - Ast_413.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), (copy_expression x1)) - | Ast_412.Parsetree.Pexp_override x0 -> - Ast_413.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_label x0), (copy_expression x1))) x0) - | Ast_412.Parsetree.Pexp_letmodule (x0, x1, x2) -> - Ast_413.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_expr x1), (copy_expression x2)) - | Ast_412.Parsetree.Pexp_letexception (x0, x1) -> - Ast_413.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), (copy_expression x1)) - | Ast_412.Parsetree.Pexp_assert x0 -> - Ast_413.Parsetree.Pexp_assert (copy_expression x0) - | Ast_412.Parsetree.Pexp_lazy x0 -> - Ast_413.Parsetree.Pexp_lazy (copy_expression x0) - | Ast_412.Parsetree.Pexp_poly (x0, x1) -> - Ast_413.Parsetree.Pexp_poly - ((copy_expression x0), (Option.map copy_core_type x1)) - | Ast_412.Parsetree.Pexp_object x0 -> - Ast_413.Parsetree.Pexp_object (copy_class_structure x0) - | Ast_412.Parsetree.Pexp_newtype (x0, x1) -> - Ast_413.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | Ast_412.Parsetree.Pexp_pack x0 -> - Ast_413.Parsetree.Pexp_pack (copy_module_expr x0) - | Ast_412.Parsetree.Pexp_open (x0, x1) -> - Ast_413.Parsetree.Pexp_open - ((copy_open_declaration x0), (copy_expression x1)) - | Ast_412.Parsetree.Pexp_letop x0 -> - Ast_413.Parsetree.Pexp_letop (copy_letop x0) - | Ast_412.Parsetree.Pexp_extension x0 -> - Ast_413.Parsetree.Pexp_extension (copy_extension x0) - | Ast_412.Parsetree.Pexp_unreachable -> Ast_413.Parsetree.Pexp_unreachable -and copy_letop : Ast_412.Parsetree.letop -> Ast_413.Parsetree.letop = - fun - { Ast_412.Parsetree.let_ = let_; Ast_412.Parsetree.ands = ands; - Ast_412.Parsetree.body = body } - -> - { - Ast_413.Parsetree.let_ = (copy_binding_op let_); - Ast_413.Parsetree.ands = (List.map copy_binding_op ands); - Ast_413.Parsetree.body = (copy_expression body) - } -and copy_binding_op : - Ast_412.Parsetree.binding_op -> Ast_413.Parsetree.binding_op = - fun - { Ast_412.Parsetree.pbop_op = pbop_op; - Ast_412.Parsetree.pbop_pat = pbop_pat; - Ast_412.Parsetree.pbop_exp = pbop_exp; - Ast_412.Parsetree.pbop_loc = pbop_loc } - -> - { - Ast_413.Parsetree.pbop_op = (copy_loc (fun x -> x) pbop_op); - Ast_413.Parsetree.pbop_pat = (copy_pattern pbop_pat); - Ast_413.Parsetree.pbop_exp = (copy_expression pbop_exp); - Ast_413.Parsetree.pbop_loc = (copy_location pbop_loc) - } -and copy_direction_flag : - Ast_412.Asttypes.direction_flag -> Ast_413.Asttypes.direction_flag = - function - | Ast_412.Asttypes.Upto -> Ast_413.Asttypes.Upto - | Ast_412.Asttypes.Downto -> Ast_413.Asttypes.Downto -and copy_case : Ast_412.Parsetree.case -> Ast_413.Parsetree.case = - fun - { Ast_412.Parsetree.pc_lhs = pc_lhs; - Ast_412.Parsetree.pc_guard = pc_guard; - Ast_412.Parsetree.pc_rhs = pc_rhs } - -> - { - Ast_413.Parsetree.pc_lhs = (copy_pattern pc_lhs); - Ast_413.Parsetree.pc_guard = (Option.map copy_expression pc_guard); - Ast_413.Parsetree.pc_rhs = (copy_expression pc_rhs) - } -and copy_value_binding : - Ast_412.Parsetree.value_binding -> Ast_413.Parsetree.value_binding = - fun - { Ast_412.Parsetree.pvb_pat = pvb_pat; - Ast_412.Parsetree.pvb_expr = pvb_expr; - Ast_412.Parsetree.pvb_attributes = pvb_attributes; - Ast_412.Parsetree.pvb_loc = pvb_loc } - -> - { - Ast_413.Parsetree.pvb_pat = (copy_pattern pvb_pat); - Ast_413.Parsetree.pvb_expr = (copy_expression pvb_expr); - Ast_413.Parsetree.pvb_attributes = (copy_attributes pvb_attributes); - Ast_413.Parsetree.pvb_loc = (copy_location pvb_loc) - } -and copy_pattern : Ast_412.Parsetree.pattern -> Ast_413.Parsetree.pattern = - fun - { Ast_412.Parsetree.ppat_desc = ppat_desc; - Ast_412.Parsetree.ppat_loc = ppat_loc; - Ast_412.Parsetree.ppat_loc_stack = ppat_loc_stack; - Ast_412.Parsetree.ppat_attributes = ppat_attributes } - -> - { - Ast_413.Parsetree.ppat_desc = (copy_pattern_desc ppat_desc); - Ast_413.Parsetree.ppat_loc = (copy_location ppat_loc); - Ast_413.Parsetree.ppat_loc_stack = (copy_location_stack ppat_loc_stack); - Ast_413.Parsetree.ppat_attributes = (copy_attributes ppat_attributes) - } -and copy_pattern_desc : - Ast_412.Parsetree.pattern_desc -> Ast_413.Parsetree.pattern_desc = - function - | Ast_412.Parsetree.Ppat_any -> Ast_413.Parsetree.Ppat_any - | Ast_412.Parsetree.Ppat_var x0 -> - Ast_413.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | Ast_412.Parsetree.Ppat_alias (x0, x1) -> - Ast_413.Parsetree.Ppat_alias - ((copy_pattern x0), (copy_loc (fun x -> x) x1)) - | Ast_412.Parsetree.Ppat_constant x0 -> - Ast_413.Parsetree.Ppat_constant (copy_constant x0) - | Ast_412.Parsetree.Ppat_interval (x0, x1) -> - Ast_413.Parsetree.Ppat_interval - ((copy_constant x0), (copy_constant x1)) - | Ast_412.Parsetree.Ppat_tuple x0 -> - Ast_413.Parsetree.Ppat_tuple (List.map copy_pattern x0) - | Ast_412.Parsetree.Ppat_construct (x0, x1) -> - Ast_413.Parsetree.Ppat_construct - ((copy_loc copy_Longident_t x0), (Option.map (fun x -> [], copy_pattern x) x1)) - | Ast_412.Parsetree.Ppat_variant (x0, x1) -> - Ast_413.Parsetree.Ppat_variant - ((copy_label x0), (Option.map copy_pattern x1)) - | Ast_412.Parsetree.Ppat_record (x0, x1) -> - Ast_413.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | Ast_412.Parsetree.Ppat_array x0 -> - Ast_413.Parsetree.Ppat_array (List.map copy_pattern x0) - | Ast_412.Parsetree.Ppat_or (x0, x1) -> - Ast_413.Parsetree.Ppat_or ((copy_pattern x0), (copy_pattern x1)) - | Ast_412.Parsetree.Ppat_constraint (x0, x1) -> - Ast_413.Parsetree.Ppat_constraint - ((copy_pattern x0), (copy_core_type x1)) - | Ast_412.Parsetree.Ppat_type x0 -> - Ast_413.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) - | Ast_412.Parsetree.Ppat_lazy x0 -> - Ast_413.Parsetree.Ppat_lazy (copy_pattern x0) - | Ast_412.Parsetree.Ppat_unpack x0 -> - Ast_413.Parsetree.Ppat_unpack - (copy_loc (fun x -> Option.map (fun x -> x) x) x0) - | Ast_412.Parsetree.Ppat_exception x0 -> - Ast_413.Parsetree.Ppat_exception (copy_pattern x0) - | Ast_412.Parsetree.Ppat_extension x0 -> - Ast_413.Parsetree.Ppat_extension (copy_extension x0) - | Ast_412.Parsetree.Ppat_open (x0, x1) -> - Ast_413.Parsetree.Ppat_open - ((copy_loc copy_Longident_t x0), (copy_pattern x1)) -and copy_core_type : - Ast_412.Parsetree.core_type -> Ast_413.Parsetree.core_type = - fun - { Ast_412.Parsetree.ptyp_desc = ptyp_desc; - Ast_412.Parsetree.ptyp_loc = ptyp_loc; - Ast_412.Parsetree.ptyp_loc_stack = ptyp_loc_stack; - Ast_412.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - Ast_413.Parsetree.ptyp_desc = (copy_core_type_desc ptyp_desc); - Ast_413.Parsetree.ptyp_loc = (copy_location ptyp_loc); - Ast_413.Parsetree.ptyp_loc_stack = (copy_location_stack ptyp_loc_stack); - Ast_413.Parsetree.ptyp_attributes = (copy_attributes ptyp_attributes) - } -and copy_location_stack : - Ast_412.Parsetree.location_stack -> Ast_413.Parsetree.location_stack = - fun x -> List.map copy_location x -and copy_core_type_desc : - Ast_412.Parsetree.core_type_desc -> Ast_413.Parsetree.core_type_desc = - function - | Ast_412.Parsetree.Ptyp_any -> Ast_413.Parsetree.Ptyp_any - | Ast_412.Parsetree.Ptyp_var x0 -> Ast_413.Parsetree.Ptyp_var x0 - | Ast_412.Parsetree.Ptyp_arrow (x0, x1, x2) -> - Ast_413.Parsetree.Ptyp_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_core_type x2)) - | Ast_412.Parsetree.Ptyp_tuple x0 -> - Ast_413.Parsetree.Ptyp_tuple (List.map copy_core_type x0) - | Ast_412.Parsetree.Ptyp_constr (x0, x1) -> - Ast_413.Parsetree.Ptyp_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_412.Parsetree.Ptyp_object (x0, x1) -> - Ast_413.Parsetree.Ptyp_object - ((List.map copy_object_field x0), (copy_closed_flag x1)) - | Ast_412.Parsetree.Ptyp_class (x0, x1) -> - Ast_413.Parsetree.Ptyp_class - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_412.Parsetree.Ptyp_alias (x0, x1) -> - Ast_413.Parsetree.Ptyp_alias ((copy_core_type x0), x1) - | Ast_412.Parsetree.Ptyp_variant (x0, x1, x2) -> - Ast_413.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), (copy_closed_flag x1), - (Option.map (fun x -> List.map copy_label x) x2)) - | Ast_412.Parsetree.Ptyp_poly (x0, x1) -> - Ast_413.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | Ast_412.Parsetree.Ptyp_package x0 -> - Ast_413.Parsetree.Ptyp_package (copy_package_type x0) - | Ast_412.Parsetree.Ptyp_extension x0 -> - Ast_413.Parsetree.Ptyp_extension (copy_extension x0) -and copy_package_type : - Ast_412.Parsetree.package_type -> Ast_413.Parsetree.package_type = - fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_core_type x1))) x1)) -and copy_row_field : - Ast_412.Parsetree.row_field -> Ast_413.Parsetree.row_field = - fun - { Ast_412.Parsetree.prf_desc = prf_desc; - Ast_412.Parsetree.prf_loc = prf_loc; - Ast_412.Parsetree.prf_attributes = prf_attributes } - -> - { - Ast_413.Parsetree.prf_desc = (copy_row_field_desc prf_desc); - Ast_413.Parsetree.prf_loc = (copy_location prf_loc); - Ast_413.Parsetree.prf_attributes = (copy_attributes prf_attributes) - } -and copy_row_field_desc : - Ast_412.Parsetree.row_field_desc -> Ast_413.Parsetree.row_field_desc = - function - | Ast_412.Parsetree.Rtag (x0, x1, x2) -> - Ast_413.Parsetree.Rtag - ((copy_loc copy_label x0), x1, (List.map copy_core_type x2)) - | Ast_412.Parsetree.Rinherit x0 -> - Ast_413.Parsetree.Rinherit (copy_core_type x0) -and copy_object_field : - Ast_412.Parsetree.object_field -> Ast_413.Parsetree.object_field = - fun - { Ast_412.Parsetree.pof_desc = pof_desc; - Ast_412.Parsetree.pof_loc = pof_loc; - Ast_412.Parsetree.pof_attributes = pof_attributes } - -> - { - Ast_413.Parsetree.pof_desc = (copy_object_field_desc pof_desc); - Ast_413.Parsetree.pof_loc = (copy_location pof_loc); - Ast_413.Parsetree.pof_attributes = (copy_attributes pof_attributes) - } -and copy_attributes : - Ast_412.Parsetree.attributes -> Ast_413.Parsetree.attributes = - fun x -> List.map copy_attribute x -and copy_attribute : - Ast_412.Parsetree.attribute -> Ast_413.Parsetree.attribute = - fun - { Ast_412.Parsetree.attr_name = attr_name; - Ast_412.Parsetree.attr_payload = attr_payload; - Ast_412.Parsetree.attr_loc = attr_loc } - -> - { - Ast_413.Parsetree.attr_name = (copy_loc (fun x -> x) attr_name); - Ast_413.Parsetree.attr_payload = (copy_payload attr_payload); - Ast_413.Parsetree.attr_loc = (copy_location attr_loc) - } -and copy_payload : Ast_412.Parsetree.payload -> Ast_413.Parsetree.payload = - function - | Ast_412.Parsetree.PStr x0 -> Ast_413.Parsetree.PStr (copy_structure x0) - | Ast_412.Parsetree.PSig x0 -> Ast_413.Parsetree.PSig (copy_signature x0) - | Ast_412.Parsetree.PTyp x0 -> Ast_413.Parsetree.PTyp (copy_core_type x0) - | Ast_412.Parsetree.PPat (x0, x1) -> - Ast_413.Parsetree.PPat - ((copy_pattern x0), (Option.map copy_expression x1)) -and copy_structure : - Ast_412.Parsetree.structure -> Ast_413.Parsetree.structure = - fun x -> List.map copy_structure_item x -and copy_structure_item : - Ast_412.Parsetree.structure_item -> Ast_413.Parsetree.structure_item = - fun - { Ast_412.Parsetree.pstr_desc = pstr_desc; - Ast_412.Parsetree.pstr_loc = pstr_loc } - -> - { - Ast_413.Parsetree.pstr_desc = (copy_structure_item_desc pstr_desc); - Ast_413.Parsetree.pstr_loc = (copy_location pstr_loc) - } -and copy_structure_item_desc : - Ast_412.Parsetree.structure_item_desc -> - Ast_413.Parsetree.structure_item_desc - = - function - | Ast_412.Parsetree.Pstr_eval (x0, x1) -> - Ast_413.Parsetree.Pstr_eval - ((copy_expression x0), (copy_attributes x1)) - | Ast_412.Parsetree.Pstr_value (x0, x1) -> - Ast_413.Parsetree.Pstr_value - ((copy_rec_flag x0), (List.map copy_value_binding x1)) - | Ast_412.Parsetree.Pstr_primitive x0 -> - Ast_413.Parsetree.Pstr_primitive (copy_value_description x0) - | Ast_412.Parsetree.Pstr_type (x0, x1) -> - Ast_413.Parsetree.Pstr_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_412.Parsetree.Pstr_typext x0 -> - Ast_413.Parsetree.Pstr_typext (copy_type_extension x0) - | Ast_412.Parsetree.Pstr_exception x0 -> - Ast_413.Parsetree.Pstr_exception (copy_type_exception x0) - | Ast_412.Parsetree.Pstr_module x0 -> - Ast_413.Parsetree.Pstr_module (copy_module_binding x0) - | Ast_412.Parsetree.Pstr_recmodule x0 -> - Ast_413.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) - | Ast_412.Parsetree.Pstr_modtype x0 -> - Ast_413.Parsetree.Pstr_modtype (copy_module_type_declaration x0) - | Ast_412.Parsetree.Pstr_open x0 -> - Ast_413.Parsetree.Pstr_open (copy_open_declaration x0) - | Ast_412.Parsetree.Pstr_class x0 -> - Ast_413.Parsetree.Pstr_class (List.map copy_class_declaration x0) - | Ast_412.Parsetree.Pstr_class_type x0 -> - Ast_413.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | Ast_412.Parsetree.Pstr_include x0 -> - Ast_413.Parsetree.Pstr_include (copy_include_declaration x0) - | Ast_412.Parsetree.Pstr_attribute x0 -> - Ast_413.Parsetree.Pstr_attribute (copy_attribute x0) - | Ast_412.Parsetree.Pstr_extension (x0, x1) -> - Ast_413.Parsetree.Pstr_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_include_declaration : - Ast_412.Parsetree.include_declaration -> - Ast_413.Parsetree.include_declaration - = fun x -> copy_include_infos copy_module_expr x -and copy_class_declaration : - Ast_412.Parsetree.class_declaration -> Ast_413.Parsetree.class_declaration - = fun x -> copy_class_infos copy_class_expr x -and copy_class_expr : - Ast_412.Parsetree.class_expr -> Ast_413.Parsetree.class_expr = - fun - { Ast_412.Parsetree.pcl_desc = pcl_desc; - Ast_412.Parsetree.pcl_loc = pcl_loc; - Ast_412.Parsetree.pcl_attributes = pcl_attributes } - -> - { - Ast_413.Parsetree.pcl_desc = (copy_class_expr_desc pcl_desc); - Ast_413.Parsetree.pcl_loc = (copy_location pcl_loc); - Ast_413.Parsetree.pcl_attributes = (copy_attributes pcl_attributes) - } -and copy_class_expr_desc : - Ast_412.Parsetree.class_expr_desc -> Ast_413.Parsetree.class_expr_desc = - function - | Ast_412.Parsetree.Pcl_constr (x0, x1) -> - Ast_413.Parsetree.Pcl_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_412.Parsetree.Pcl_structure x0 -> - Ast_413.Parsetree.Pcl_structure (copy_class_structure x0) - | Ast_412.Parsetree.Pcl_fun (x0, x1, x2, x3) -> - Ast_413.Parsetree.Pcl_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_class_expr x3)) - | Ast_412.Parsetree.Pcl_apply (x0, x1) -> - Ast_413.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_412.Parsetree.Pcl_let (x0, x1, x2) -> - Ast_413.Parsetree.Pcl_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_class_expr x2)) - | Ast_412.Parsetree.Pcl_constraint (x0, x1) -> - Ast_413.Parsetree.Pcl_constraint - ((copy_class_expr x0), (copy_class_type x1)) - | Ast_412.Parsetree.Pcl_extension x0 -> - Ast_413.Parsetree.Pcl_extension (copy_extension x0) - | Ast_412.Parsetree.Pcl_open (x0, x1) -> - Ast_413.Parsetree.Pcl_open - ((copy_open_description x0), (copy_class_expr x1)) -and copy_class_structure : - Ast_412.Parsetree.class_structure -> Ast_413.Parsetree.class_structure = - fun - { Ast_412.Parsetree.pcstr_self = pcstr_self; - Ast_412.Parsetree.pcstr_fields = pcstr_fields } - -> - { - Ast_413.Parsetree.pcstr_self = (copy_pattern pcstr_self); - Ast_413.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } -and copy_class_field : - Ast_412.Parsetree.class_field -> Ast_413.Parsetree.class_field = - fun - { Ast_412.Parsetree.pcf_desc = pcf_desc; - Ast_412.Parsetree.pcf_loc = pcf_loc; - Ast_412.Parsetree.pcf_attributes = pcf_attributes } - -> - { - Ast_413.Parsetree.pcf_desc = (copy_class_field_desc pcf_desc); - Ast_413.Parsetree.pcf_loc = (copy_location pcf_loc); - Ast_413.Parsetree.pcf_attributes = (copy_attributes pcf_attributes) - } -and copy_class_field_desc : - Ast_412.Parsetree.class_field_desc -> Ast_413.Parsetree.class_field_desc = - function - | Ast_412.Parsetree.Pcf_inherit (x0, x1, x2) -> - Ast_413.Parsetree.Pcf_inherit - ((copy_override_flag x0), (copy_class_expr x1), - (Option.map (fun x -> copy_loc (fun x -> x) x) x2)) - | Ast_412.Parsetree.Pcf_val x0 -> - Ast_413.Parsetree.Pcf_val - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | Ast_412.Parsetree.Pcf_method x0 -> - Ast_413.Parsetree.Pcf_method - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_class_field_kind x2))) - | Ast_412.Parsetree.Pcf_constraint x0 -> - Ast_413.Parsetree.Pcf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_412.Parsetree.Pcf_initializer x0 -> - Ast_413.Parsetree.Pcf_initializer (copy_expression x0) - | Ast_412.Parsetree.Pcf_attribute x0 -> - Ast_413.Parsetree.Pcf_attribute (copy_attribute x0) - | Ast_412.Parsetree.Pcf_extension x0 -> - Ast_413.Parsetree.Pcf_extension (copy_extension x0) -and copy_class_field_kind : - Ast_412.Parsetree.class_field_kind -> Ast_413.Parsetree.class_field_kind = - function - | Ast_412.Parsetree.Cfk_virtual x0 -> - Ast_413.Parsetree.Cfk_virtual (copy_core_type x0) - | Ast_412.Parsetree.Cfk_concrete (x0, x1) -> - Ast_413.Parsetree.Cfk_concrete - ((copy_override_flag x0), (copy_expression x1)) -and copy_open_declaration : - Ast_412.Parsetree.open_declaration -> Ast_413.Parsetree.open_declaration = - fun x -> copy_open_infos copy_module_expr x -and copy_module_binding : - Ast_412.Parsetree.module_binding -> Ast_413.Parsetree.module_binding = - fun - { Ast_412.Parsetree.pmb_name = pmb_name; - Ast_412.Parsetree.pmb_expr = pmb_expr; - Ast_412.Parsetree.pmb_attributes = pmb_attributes; - Ast_412.Parsetree.pmb_loc = pmb_loc } - -> - { - Ast_413.Parsetree.pmb_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name); - Ast_413.Parsetree.pmb_expr = (copy_module_expr pmb_expr); - Ast_413.Parsetree.pmb_attributes = (copy_attributes pmb_attributes); - Ast_413.Parsetree.pmb_loc = (copy_location pmb_loc) - } -and copy_module_expr : - Ast_412.Parsetree.module_expr -> Ast_413.Parsetree.module_expr = - fun - { Ast_412.Parsetree.pmod_desc = pmod_desc; - Ast_412.Parsetree.pmod_loc = pmod_loc; - Ast_412.Parsetree.pmod_attributes = pmod_attributes } - -> - { - Ast_413.Parsetree.pmod_desc = (copy_module_expr_desc pmod_desc); - Ast_413.Parsetree.pmod_loc = (copy_location pmod_loc); - Ast_413.Parsetree.pmod_attributes = (copy_attributes pmod_attributes) - } -and copy_module_expr_desc : - Ast_412.Parsetree.module_expr_desc -> Ast_413.Parsetree.module_expr_desc = - function - | Ast_412.Parsetree.Pmod_ident x0 -> - Ast_413.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) - | Ast_412.Parsetree.Pmod_structure x0 -> - Ast_413.Parsetree.Pmod_structure (copy_structure x0) - | Ast_412.Parsetree.Pmod_functor (x0, x1) -> - Ast_413.Parsetree.Pmod_functor - ((copy_functor_parameter x0), (copy_module_expr x1)) - | Ast_412.Parsetree.Pmod_apply (x0, x1) -> - Ast_413.Parsetree.Pmod_apply - ((copy_module_expr x0), (copy_module_expr x1)) - | Ast_412.Parsetree.Pmod_constraint (x0, x1) -> - Ast_413.Parsetree.Pmod_constraint - ((copy_module_expr x0), (copy_module_type x1)) - | Ast_412.Parsetree.Pmod_unpack x0 -> - Ast_413.Parsetree.Pmod_unpack (copy_expression x0) - | Ast_412.Parsetree.Pmod_extension x0 -> - Ast_413.Parsetree.Pmod_extension (copy_extension x0) -and copy_functor_parameter : - Ast_412.Parsetree.functor_parameter -> Ast_413.Parsetree.functor_parameter - = - function - | Ast_412.Parsetree.Unit -> Ast_413.Parsetree.Unit - | Ast_412.Parsetree.Named (x0, x1) -> - Ast_413.Parsetree.Named - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_type x1)) -and copy_module_type : - Ast_412.Parsetree.module_type -> Ast_413.Parsetree.module_type = - fun - { Ast_412.Parsetree.pmty_desc = pmty_desc; - Ast_412.Parsetree.pmty_loc = pmty_loc; - Ast_412.Parsetree.pmty_attributes = pmty_attributes } - -> - { - Ast_413.Parsetree.pmty_desc = (copy_module_type_desc pmty_desc); - Ast_413.Parsetree.pmty_loc = (copy_location pmty_loc); - Ast_413.Parsetree.pmty_attributes = (copy_attributes pmty_attributes) - } -and copy_module_type_desc : - Ast_412.Parsetree.module_type_desc -> Ast_413.Parsetree.module_type_desc = - function - | Ast_412.Parsetree.Pmty_ident x0 -> - Ast_413.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) - | Ast_412.Parsetree.Pmty_signature x0 -> - Ast_413.Parsetree.Pmty_signature (copy_signature x0) - | Ast_412.Parsetree.Pmty_functor (x0, x1) -> - Ast_413.Parsetree.Pmty_functor - ((copy_functor_parameter x0), (copy_module_type x1)) - | Ast_412.Parsetree.Pmty_with (x0, x1) -> - Ast_413.Parsetree.Pmty_with - ((copy_module_type x0), (List.map copy_with_constraint x1)) - | Ast_412.Parsetree.Pmty_typeof x0 -> - Ast_413.Parsetree.Pmty_typeof (copy_module_expr x0) - | Ast_412.Parsetree.Pmty_extension x0 -> - Ast_413.Parsetree.Pmty_extension (copy_extension x0) - | Ast_412.Parsetree.Pmty_alias x0 -> - Ast_413.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) -and copy_with_constraint : - Ast_412.Parsetree.with_constraint -> Ast_413.Parsetree.with_constraint = - function - | Ast_412.Parsetree.Pwith_type (x0, x1) -> - Ast_413.Parsetree.Pwith_type - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_412.Parsetree.Pwith_module (x0, x1) -> - Ast_413.Parsetree.Pwith_module - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) - | Ast_412.Parsetree.Pwith_typesubst (x0, x1) -> - Ast_413.Parsetree.Pwith_typesubst - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_412.Parsetree.Pwith_modsubst (x0, x1) -> - Ast_413.Parsetree.Pwith_modsubst - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) -and copy_signature : - Ast_412.Parsetree.signature -> Ast_413.Parsetree.signature = - fun x -> List.map copy_signature_item x -and copy_signature_item : - Ast_412.Parsetree.signature_item -> Ast_413.Parsetree.signature_item = - fun - { Ast_412.Parsetree.psig_desc = psig_desc; - Ast_412.Parsetree.psig_loc = psig_loc } - -> - { - Ast_413.Parsetree.psig_desc = (copy_signature_item_desc psig_desc); - Ast_413.Parsetree.psig_loc = (copy_location psig_loc) - } -and copy_signature_item_desc : - Ast_412.Parsetree.signature_item_desc -> - Ast_413.Parsetree.signature_item_desc - = - function - | Ast_412.Parsetree.Psig_value x0 -> - Ast_413.Parsetree.Psig_value (copy_value_description x0) - | Ast_412.Parsetree.Psig_type (x0, x1) -> - Ast_413.Parsetree.Psig_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_412.Parsetree.Psig_typesubst x0 -> - Ast_413.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) - | Ast_412.Parsetree.Psig_typext x0 -> - Ast_413.Parsetree.Psig_typext (copy_type_extension x0) - | Ast_412.Parsetree.Psig_exception x0 -> - Ast_413.Parsetree.Psig_exception (copy_type_exception x0) - | Ast_412.Parsetree.Psig_module x0 -> - Ast_413.Parsetree.Psig_module (copy_module_declaration x0) - | Ast_412.Parsetree.Psig_modsubst x0 -> - Ast_413.Parsetree.Psig_modsubst (copy_module_substitution x0) - | Ast_412.Parsetree.Psig_recmodule x0 -> - Ast_413.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) - | Ast_412.Parsetree.Psig_modtype x0 -> - Ast_413.Parsetree.Psig_modtype (copy_module_type_declaration x0) - | Ast_412.Parsetree.Psig_open x0 -> - Ast_413.Parsetree.Psig_open (copy_open_description x0) - | Ast_412.Parsetree.Psig_include x0 -> - Ast_413.Parsetree.Psig_include (copy_include_description x0) - | Ast_412.Parsetree.Psig_class x0 -> - Ast_413.Parsetree.Psig_class (List.map copy_class_description x0) - | Ast_412.Parsetree.Psig_class_type x0 -> - Ast_413.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | Ast_412.Parsetree.Psig_attribute x0 -> - Ast_413.Parsetree.Psig_attribute (copy_attribute x0) - | Ast_412.Parsetree.Psig_extension (x0, x1) -> - Ast_413.Parsetree.Psig_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_class_type_declaration : - Ast_412.Parsetree.class_type_declaration -> - Ast_413.Parsetree.class_type_declaration - = fun x -> copy_class_infos copy_class_type x -and copy_class_description : - Ast_412.Parsetree.class_description -> Ast_413.Parsetree.class_description - = fun x -> copy_class_infos copy_class_type x -and copy_class_type : - Ast_412.Parsetree.class_type -> Ast_413.Parsetree.class_type = - fun - { Ast_412.Parsetree.pcty_desc = pcty_desc; - Ast_412.Parsetree.pcty_loc = pcty_loc; - Ast_412.Parsetree.pcty_attributes = pcty_attributes } - -> - { - Ast_413.Parsetree.pcty_desc = (copy_class_type_desc pcty_desc); - Ast_413.Parsetree.pcty_loc = (copy_location pcty_loc); - Ast_413.Parsetree.pcty_attributes = (copy_attributes pcty_attributes) - } -and copy_class_type_desc : - Ast_412.Parsetree.class_type_desc -> Ast_413.Parsetree.class_type_desc = - function - | Ast_412.Parsetree.Pcty_constr (x0, x1) -> - Ast_413.Parsetree.Pcty_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_412.Parsetree.Pcty_signature x0 -> - Ast_413.Parsetree.Pcty_signature (copy_class_signature x0) - | Ast_412.Parsetree.Pcty_arrow (x0, x1, x2) -> - Ast_413.Parsetree.Pcty_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_class_type x2)) - | Ast_412.Parsetree.Pcty_extension x0 -> - Ast_413.Parsetree.Pcty_extension (copy_extension x0) - | Ast_412.Parsetree.Pcty_open (x0, x1) -> - Ast_413.Parsetree.Pcty_open - ((copy_open_description x0), (copy_class_type x1)) -and copy_class_signature : - Ast_412.Parsetree.class_signature -> Ast_413.Parsetree.class_signature = - fun - { Ast_412.Parsetree.pcsig_self = pcsig_self; - Ast_412.Parsetree.pcsig_fields = pcsig_fields } - -> - { - Ast_413.Parsetree.pcsig_self = (copy_core_type pcsig_self); - Ast_413.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } -and copy_class_type_field : - Ast_412.Parsetree.class_type_field -> Ast_413.Parsetree.class_type_field = - fun - { Ast_412.Parsetree.pctf_desc = pctf_desc; - Ast_412.Parsetree.pctf_loc = pctf_loc; - Ast_412.Parsetree.pctf_attributes = pctf_attributes } - -> - { - Ast_413.Parsetree.pctf_desc = (copy_class_type_field_desc pctf_desc); - Ast_413.Parsetree.pctf_loc = (copy_location pctf_loc); - Ast_413.Parsetree.pctf_attributes = (copy_attributes pctf_attributes) - } -and copy_class_type_field_desc : - Ast_412.Parsetree.class_type_field_desc -> - Ast_413.Parsetree.class_type_field_desc - = - function - | Ast_412.Parsetree.Pctf_inherit x0 -> - Ast_413.Parsetree.Pctf_inherit (copy_class_type x0) - | Ast_412.Parsetree.Pctf_val x0 -> - Ast_413.Parsetree.Pctf_val - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_412.Parsetree.Pctf_method x0 -> - Ast_413.Parsetree.Pctf_method - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_412.Parsetree.Pctf_constraint x0 -> - Ast_413.Parsetree.Pctf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_412.Parsetree.Pctf_attribute x0 -> - Ast_413.Parsetree.Pctf_attribute (copy_attribute x0) - | Ast_412.Parsetree.Pctf_extension x0 -> - Ast_413.Parsetree.Pctf_extension (copy_extension x0) -and copy_extension : - Ast_412.Parsetree.extension -> Ast_413.Parsetree.extension = - fun x -> - let (x0, x1) = x in ((copy_loc (fun x -> x) x0), (copy_payload x1)) -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_412.Parsetree.class_infos -> 'g0 Ast_413.Parsetree.class_infos - = - fun f0 -> - fun - { Ast_412.Parsetree.pci_virt = pci_virt; - Ast_412.Parsetree.pci_params = pci_params; - Ast_412.Parsetree.pci_name = pci_name; - Ast_412.Parsetree.pci_expr = pci_expr; - Ast_412.Parsetree.pci_loc = pci_loc; - Ast_412.Parsetree.pci_attributes = pci_attributes } - -> - { - Ast_413.Parsetree.pci_virt = (copy_virtual_flag pci_virt); - Ast_413.Parsetree.pci_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) pci_params); - Ast_413.Parsetree.pci_name = (copy_loc (fun x -> x) pci_name); - Ast_413.Parsetree.pci_expr = (f0 pci_expr); - Ast_413.Parsetree.pci_loc = (copy_location pci_loc); - Ast_413.Parsetree.pci_attributes = (copy_attributes pci_attributes) - } -and copy_virtual_flag : - Ast_412.Asttypes.virtual_flag -> Ast_413.Asttypes.virtual_flag = - function - | Ast_412.Asttypes.Virtual -> Ast_413.Asttypes.Virtual - | Ast_412.Asttypes.Concrete -> Ast_413.Asttypes.Concrete -and copy_include_description : - Ast_412.Parsetree.include_description -> - Ast_413.Parsetree.include_description - = fun x -> copy_include_infos copy_module_type x -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_412.Parsetree.include_infos -> - 'g0 Ast_413.Parsetree.include_infos - = - fun f0 -> - fun - { Ast_412.Parsetree.pincl_mod = pincl_mod; - Ast_412.Parsetree.pincl_loc = pincl_loc; - Ast_412.Parsetree.pincl_attributes = pincl_attributes } - -> - { - Ast_413.Parsetree.pincl_mod = (f0 pincl_mod); - Ast_413.Parsetree.pincl_loc = (copy_location pincl_loc); - Ast_413.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } -and copy_open_description : - Ast_412.Parsetree.open_description -> Ast_413.Parsetree.open_description = - fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x -and copy_open_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_412.Parsetree.open_infos -> 'g0 Ast_413.Parsetree.open_infos - = - fun f0 -> - fun - { Ast_412.Parsetree.popen_expr = popen_expr; - Ast_412.Parsetree.popen_override = popen_override; - Ast_412.Parsetree.popen_loc = popen_loc; - Ast_412.Parsetree.popen_attributes = popen_attributes } - -> - { - Ast_413.Parsetree.popen_expr = (f0 popen_expr); - Ast_413.Parsetree.popen_override = - (copy_override_flag popen_override); - Ast_413.Parsetree.popen_loc = (copy_location popen_loc); - Ast_413.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } -and copy_override_flag : - Ast_412.Asttypes.override_flag -> Ast_413.Asttypes.override_flag = - function - | Ast_412.Asttypes.Override -> Ast_413.Asttypes.Override - | Ast_412.Asttypes.Fresh -> Ast_413.Asttypes.Fresh -and copy_module_type_declaration : - Ast_412.Parsetree.module_type_declaration -> - Ast_413.Parsetree.module_type_declaration - = - fun - { Ast_412.Parsetree.pmtd_name = pmtd_name; - Ast_412.Parsetree.pmtd_type = pmtd_type; - Ast_412.Parsetree.pmtd_attributes = pmtd_attributes; - Ast_412.Parsetree.pmtd_loc = pmtd_loc } - -> - { - Ast_413.Parsetree.pmtd_name = (copy_loc (fun x -> x) pmtd_name); - Ast_413.Parsetree.pmtd_type = (Option.map copy_module_type pmtd_type); - Ast_413.Parsetree.pmtd_attributes = (copy_attributes pmtd_attributes); - Ast_413.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } -and copy_module_substitution : - Ast_412.Parsetree.module_substitution -> - Ast_413.Parsetree.module_substitution - = - fun - { Ast_412.Parsetree.pms_name = pms_name; - Ast_412.Parsetree.pms_manifest = pms_manifest; - Ast_412.Parsetree.pms_attributes = pms_attributes; - Ast_412.Parsetree.pms_loc = pms_loc } - -> - { - Ast_413.Parsetree.pms_name = (copy_loc (fun x -> x) pms_name); - Ast_413.Parsetree.pms_manifest = - (copy_loc copy_Longident_t pms_manifest); - Ast_413.Parsetree.pms_attributes = (copy_attributes pms_attributes); - Ast_413.Parsetree.pms_loc = (copy_location pms_loc) - } -and copy_module_declaration : - Ast_412.Parsetree.module_declaration -> - Ast_413.Parsetree.module_declaration - = - fun - { Ast_412.Parsetree.pmd_name = pmd_name; - Ast_412.Parsetree.pmd_type = pmd_type; - Ast_412.Parsetree.pmd_attributes = pmd_attributes; - Ast_412.Parsetree.pmd_loc = pmd_loc } - -> - { - Ast_413.Parsetree.pmd_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name); - Ast_413.Parsetree.pmd_type = (copy_module_type pmd_type); - Ast_413.Parsetree.pmd_attributes = (copy_attributes pmd_attributes); - Ast_413.Parsetree.pmd_loc = (copy_location pmd_loc) - } -and copy_type_exception : - Ast_412.Parsetree.type_exception -> Ast_413.Parsetree.type_exception = - fun - { Ast_412.Parsetree.ptyexn_constructor = ptyexn_constructor; - Ast_412.Parsetree.ptyexn_loc = ptyexn_loc; - Ast_412.Parsetree.ptyexn_attributes = ptyexn_attributes } - -> - { - Ast_413.Parsetree.ptyexn_constructor = - (copy_extension_constructor ptyexn_constructor); - Ast_413.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); - Ast_413.Parsetree.ptyexn_attributes = - (copy_attributes ptyexn_attributes) - } -and copy_type_extension : - Ast_412.Parsetree.type_extension -> Ast_413.Parsetree.type_extension = - fun - { Ast_412.Parsetree.ptyext_path = ptyext_path; - Ast_412.Parsetree.ptyext_params = ptyext_params; - Ast_412.Parsetree.ptyext_constructors = ptyext_constructors; - Ast_412.Parsetree.ptyext_private = ptyext_private; - Ast_412.Parsetree.ptyext_loc = ptyext_loc; - Ast_412.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - Ast_413.Parsetree.ptyext_path = (copy_loc copy_Longident_t ptyext_path); - Ast_413.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) ptyext_params); - Ast_413.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor ptyext_constructors); - Ast_413.Parsetree.ptyext_private = (copy_private_flag ptyext_private); - Ast_413.Parsetree.ptyext_loc = (copy_location ptyext_loc); - Ast_413.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } -and copy_extension_constructor : - Ast_412.Parsetree.extension_constructor -> - Ast_413.Parsetree.extension_constructor - = - fun - { Ast_412.Parsetree.pext_name = pext_name; - Ast_412.Parsetree.pext_kind = pext_kind; - Ast_412.Parsetree.pext_loc = pext_loc; - Ast_412.Parsetree.pext_attributes = pext_attributes } - -> - { - Ast_413.Parsetree.pext_name = (copy_loc (fun x -> x) pext_name); - Ast_413.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - Ast_413.Parsetree.pext_loc = (copy_location pext_loc); - Ast_413.Parsetree.pext_attributes = (copy_attributes pext_attributes) - } -and copy_extension_constructor_kind : - Ast_412.Parsetree.extension_constructor_kind -> - Ast_413.Parsetree.extension_constructor_kind - = - function - | Ast_412.Parsetree.Pext_decl (x0, x1) -> - Ast_413.Parsetree.Pext_decl - ((copy_constructor_arguments x0), (Option.map copy_core_type x1)) - | Ast_412.Parsetree.Pext_rebind x0 -> - Ast_413.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) -and copy_type_declaration : - Ast_412.Parsetree.type_declaration -> Ast_413.Parsetree.type_declaration = - fun - { Ast_412.Parsetree.ptype_name = ptype_name; - Ast_412.Parsetree.ptype_params = ptype_params; - Ast_412.Parsetree.ptype_cstrs = ptype_cstrs; - Ast_412.Parsetree.ptype_kind = ptype_kind; - Ast_412.Parsetree.ptype_private = ptype_private; - Ast_412.Parsetree.ptype_manifest = ptype_manifest; - Ast_412.Parsetree.ptype_attributes = ptype_attributes; - Ast_412.Parsetree.ptype_loc = ptype_loc } - -> - { - Ast_413.Parsetree.ptype_name = (copy_loc (fun x -> x) ptype_name); - Ast_413.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) ptype_params); - Ast_413.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0, x1, x2) = x in - ((copy_core_type x0), (copy_core_type x1), (copy_location x2))) - ptype_cstrs); - Ast_413.Parsetree.ptype_kind = (copy_type_kind ptype_kind); - Ast_413.Parsetree.ptype_private = (copy_private_flag ptype_private); - Ast_413.Parsetree.ptype_manifest = - (Option.map copy_core_type ptype_manifest); - Ast_413.Parsetree.ptype_attributes = (copy_attributes ptype_attributes); - Ast_413.Parsetree.ptype_loc = (copy_location ptype_loc) - } -and copy_private_flag : - Ast_412.Asttypes.private_flag -> Ast_413.Asttypes.private_flag = - function - | Ast_412.Asttypes.Private -> Ast_413.Asttypes.Private - | Ast_412.Asttypes.Public -> Ast_413.Asttypes.Public -and copy_type_kind : - Ast_412.Parsetree.type_kind -> Ast_413.Parsetree.type_kind = - function - | Ast_412.Parsetree.Ptype_abstract -> Ast_413.Parsetree.Ptype_abstract - | Ast_412.Parsetree.Ptype_variant x0 -> - Ast_413.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | Ast_412.Parsetree.Ptype_record x0 -> - Ast_413.Parsetree.Ptype_record (List.map copy_label_declaration x0) - | Ast_412.Parsetree.Ptype_open -> Ast_413.Parsetree.Ptype_open -and copy_constructor_declaration : - Ast_412.Parsetree.constructor_declaration -> - Ast_413.Parsetree.constructor_declaration - = - fun - { Ast_412.Parsetree.pcd_name = pcd_name; - Ast_412.Parsetree.pcd_args = pcd_args; - Ast_412.Parsetree.pcd_res = pcd_res; - Ast_412.Parsetree.pcd_loc = pcd_loc; - Ast_412.Parsetree.pcd_attributes = pcd_attributes } - -> - { - Ast_413.Parsetree.pcd_name = (copy_loc (fun x -> x) pcd_name); - Ast_413.Parsetree.pcd_args = (copy_constructor_arguments pcd_args); - Ast_413.Parsetree.pcd_res = (Option.map copy_core_type pcd_res); - Ast_413.Parsetree.pcd_loc = (copy_location pcd_loc); - Ast_413.Parsetree.pcd_attributes = (copy_attributes pcd_attributes) - } -and copy_constructor_arguments : - Ast_412.Parsetree.constructor_arguments -> - Ast_413.Parsetree.constructor_arguments - = - function - | Ast_412.Parsetree.Pcstr_tuple x0 -> - Ast_413.Parsetree.Pcstr_tuple (List.map copy_core_type x0) - | Ast_412.Parsetree.Pcstr_record x0 -> - Ast_413.Parsetree.Pcstr_record (List.map copy_label_declaration x0) -and copy_label_declaration : - Ast_412.Parsetree.label_declaration -> Ast_413.Parsetree.label_declaration - = - fun - { Ast_412.Parsetree.pld_name = pld_name; - Ast_412.Parsetree.pld_mutable = pld_mutable; - Ast_412.Parsetree.pld_type = pld_type; - Ast_412.Parsetree.pld_loc = pld_loc; - Ast_412.Parsetree.pld_attributes = pld_attributes } - -> - { - Ast_413.Parsetree.pld_name = (copy_loc (fun x -> x) pld_name); - Ast_413.Parsetree.pld_mutable = (copy_mutable_flag pld_mutable); - Ast_413.Parsetree.pld_type = (copy_core_type pld_type); - Ast_413.Parsetree.pld_loc = (copy_location pld_loc); - Ast_413.Parsetree.pld_attributes = (copy_attributes pld_attributes) - } -and copy_mutable_flag : - Ast_412.Asttypes.mutable_flag -> Ast_413.Asttypes.mutable_flag = - function - | Ast_412.Asttypes.Immutable -> Ast_413.Asttypes.Immutable - | Ast_412.Asttypes.Mutable -> Ast_413.Asttypes.Mutable -and copy_injectivity : - Ast_412.Asttypes.injectivity -> Ast_413.Asttypes.injectivity = - function - | Ast_412.Asttypes.Injective -> Ast_413.Asttypes.Injective - | Ast_412.Asttypes.NoInjectivity -> Ast_413.Asttypes.NoInjectivity -and copy_variance : Ast_412.Asttypes.variance -> Ast_413.Asttypes.variance = - function - | Ast_412.Asttypes.Covariant -> Ast_413.Asttypes.Covariant - | Ast_412.Asttypes.Contravariant -> Ast_413.Asttypes.Contravariant - | Ast_412.Asttypes.NoVariance -> Ast_413.Asttypes.NoVariance -and copy_value_description : - Ast_412.Parsetree.value_description -> Ast_413.Parsetree.value_description - = - fun - { Ast_412.Parsetree.pval_name = pval_name; - Ast_412.Parsetree.pval_type = pval_type; - Ast_412.Parsetree.pval_prim = pval_prim; - Ast_412.Parsetree.pval_attributes = pval_attributes; - Ast_412.Parsetree.pval_loc = pval_loc } - -> - { - Ast_413.Parsetree.pval_name = (copy_loc (fun x -> x) pval_name); - Ast_413.Parsetree.pval_type = (copy_core_type pval_type); - Ast_413.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - Ast_413.Parsetree.pval_attributes = (copy_attributes pval_attributes); - Ast_413.Parsetree.pval_loc = (copy_location pval_loc) - } -and copy_object_field_desc : - Ast_412.Parsetree.object_field_desc -> Ast_413.Parsetree.object_field_desc - = - function - | Ast_412.Parsetree.Otag (x0, x1) -> - Ast_413.Parsetree.Otag ((copy_loc copy_label x0), (copy_core_type x1)) - | Ast_412.Parsetree.Oinherit x0 -> - Ast_413.Parsetree.Oinherit (copy_core_type x0) -and copy_arg_label : Ast_412.Asttypes.arg_label -> Ast_413.Asttypes.arg_label - = - function - | Ast_412.Asttypes.Nolabel -> Ast_413.Asttypes.Nolabel - | Ast_412.Asttypes.Labelled x0 -> Ast_413.Asttypes.Labelled x0 - | Ast_412.Asttypes.Optional x0 -> Ast_413.Asttypes.Optional x0 -and copy_closed_flag : - Ast_412.Asttypes.closed_flag -> Ast_413.Asttypes.closed_flag = - function - | Ast_412.Asttypes.Closed -> Ast_413.Asttypes.Closed - | Ast_412.Asttypes.Open -> Ast_413.Asttypes.Open -and copy_label : Ast_412.Asttypes.label -> Ast_413.Asttypes.label = - fun x -> x -and copy_rec_flag : Ast_412.Asttypes.rec_flag -> Ast_413.Asttypes.rec_flag = - function - | Ast_412.Asttypes.Nonrecursive -> Ast_413.Asttypes.Nonrecursive - | Ast_412.Asttypes.Recursive -> Ast_413.Asttypes.Recursive -and copy_constant : Ast_412.Parsetree.constant -> Ast_413.Parsetree.constant - = - function - | Ast_412.Parsetree.Pconst_integer (x0, x1) -> - Ast_413.Parsetree.Pconst_integer (x0, (Option.map (fun x -> x) x1)) - | Ast_412.Parsetree.Pconst_char x0 -> Ast_413.Parsetree.Pconst_char x0 - | Ast_412.Parsetree.Pconst_string (x0, x1, x2) -> - Ast_413.Parsetree.Pconst_string - (x0, (copy_location x1), (Option.map (fun x -> x) x2)) - | Ast_412.Parsetree.Pconst_float (x0, x1) -> - Ast_413.Parsetree.Pconst_float (x0, (Option.map (fun x -> x) x1)) -and copy_Longident_t : Longident.t -> Longident.t = - function - | Longident.Lident x0 -> Longident.Lident x0 - | Longident.Ldot (x0, x1) -> Longident.Ldot ((copy_Longident_t x0), x1) - | Longident.Lapply (x0, x1) -> - Longident.Lapply ((copy_Longident_t x0), (copy_Longident_t x1)) -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 Ast_412.Asttypes.loc -> 'g0 Ast_413.Asttypes.loc - = - fun f0 -> - fun { Ast_412.Asttypes.txt = txt; Ast_412.Asttypes.loc = loc } -> - { - Ast_413.Asttypes.txt = (f0 txt); - Ast_413.Asttypes.loc = (copy_location loc) - } -and copy_location : Location.t -> Location.t = - fun - { Location.loc_start = loc_start; Location.loc_end = loc_end; - Location.loc_ghost = loc_ghost } - -> - { - Location.loc_start = (copy_position loc_start); - Location.loc_end = (copy_position loc_end); - Location.loc_ghost = loc_ghost - } -and copy_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum - } diff --git a/src/vendored-omp/src/migrate_parsetree_413_412.ml b/src/vendored-omp/src/migrate_parsetree_413_412.ml index e97acb89c..118c1f8a3 100644 --- a/src/vendored-omp/src/migrate_parsetree_413_412.ml +++ b/src/vendored-omp/src/migrate_parsetree_413_412.ml @@ -15,131 +15,3 @@ include Migrate_parsetree_413_412_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload"; - "binding_op"; "module_substitution"; "open_declaration"; "type_exception"; - "constant" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - binding_op; - module_substitution; - open_declaration; - type_exception; - constant; - (*$*) - } as mapper) -> - - let module Def = Migrate_parsetree_def in - let module R = Migrate_parsetree_412_413_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> List.map copy_case (cases mapper (List.map R.copy_case x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expression (expr mapper (R.copy_expression x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pattern (pat mapper (R.copy_pattern x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_core_type (typ mapper (R.copy_core_type x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - binding_op = (fun _ x -> copy_binding_op (binding_op mapper (R.copy_binding_op x))); - module_substitution = (fun _ x -> copy_module_substitution (module_substitution mapper (R.copy_module_substitution x))); - open_declaration = (fun _ x -> copy_open_declaration (open_declaration mapper (R.copy_open_declaration x))); - type_exception = (fun _ x -> copy_type_exception (type_exception mapper (R.copy_type_exception x))); - constant = (fun _ x -> copy_constant (constant mapper (R.copy_constant x))); - (*$*) - } - diff --git a/src/vendored-omp/src/migrate_parsetree_413_412_migrate.ml b/src/vendored-omp/src/migrate_parsetree_413_412_migrate.ml index 50b86ddda..f274f59fa 100644 --- a/src/vendored-omp/src/migrate_parsetree_413_412_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_413_412_migrate.ml @@ -1,14 +1,6 @@ open Stdlib0 - module From = Ast_413 module To = Ast_412 - - -module Def = Migrate_parsetree_def - -let migration_error location feature = - raise (Def.Migration_error (feature, location)) - let rec copy_out_type_extension : Ast_413.Outcometree.out_type_extension -> Ast_412.Outcometree.out_type_extension @@ -164,6 +156,11 @@ and copy_out_extension_constructor : (Option.map copy_out_type oext_ret_type); Ast_412.Outcometree.oext_private = (copy_private_flag oext_private) } +and copy_private_flag : + Ast_413.Asttypes.private_flag -> Ast_412.Asttypes.private_flag = + function + | Ast_413.Asttypes.Private -> Ast_412.Asttypes.Private + | Ast_413.Asttypes.Public -> Ast_412.Asttypes.Public and copy_out_rec_status : Ast_413.Outcometree.out_rec_status -> Ast_412.Outcometree.out_rec_status = function @@ -200,6 +197,16 @@ and copy_out_type_param : fun x -> let (x0, x1) = x in (x0, (let (x0, x1) = x1 in ((copy_variance x0), (copy_injectivity x1)))) +and copy_injectivity : + Ast_413.Asttypes.injectivity -> Ast_412.Asttypes.injectivity = + function + | Ast_413.Asttypes.Injective -> Ast_412.Asttypes.Injective + | Ast_413.Asttypes.NoInjectivity -> Ast_412.Asttypes.NoInjectivity +and copy_variance : Ast_413.Asttypes.variance -> Ast_412.Asttypes.variance = + function + | Ast_413.Asttypes.Covariant -> Ast_412.Asttypes.Covariant + | Ast_413.Asttypes.Contravariant -> Ast_412.Asttypes.Contravariant + | Ast_413.Asttypes.NoVariance -> Ast_412.Asttypes.NoVariance and copy_out_type : Ast_413.Outcometree.out_type -> Ast_412.Outcometree.out_type = function @@ -321,1222 +328,3 @@ and copy_out_name : Ast_413.Outcometree.out_name -> Ast_412.Outcometree.out_name = fun { Ast_413.Outcometree.printed_name = printed_name } -> { Ast_412.Outcometree.printed_name = printed_name } -and copy_toplevel_phrase : - Ast_413.Parsetree.toplevel_phrase -> Ast_412.Parsetree.toplevel_phrase = - function - | Ast_413.Parsetree.Ptop_def x0 -> - Ast_412.Parsetree.Ptop_def (copy_structure x0) - | Ast_413.Parsetree.Ptop_dir x0 -> - Ast_412.Parsetree.Ptop_dir (copy_toplevel_directive x0) -and copy_toplevel_directive : - Ast_413.Parsetree.toplevel_directive -> - Ast_412.Parsetree.toplevel_directive - = - fun - { Ast_413.Parsetree.pdir_name = pdir_name; - Ast_413.Parsetree.pdir_arg = pdir_arg; - Ast_413.Parsetree.pdir_loc = pdir_loc } - -> - { - Ast_412.Parsetree.pdir_name = (copy_loc (fun x -> x) pdir_name); - Ast_412.Parsetree.pdir_arg = - (Option.map copy_directive_argument pdir_arg); - Ast_412.Parsetree.pdir_loc = (copy_location pdir_loc) - } -and copy_directive_argument : - Ast_413.Parsetree.directive_argument -> - Ast_412.Parsetree.directive_argument - = - fun - { Ast_413.Parsetree.pdira_desc = pdira_desc; - Ast_413.Parsetree.pdira_loc = pdira_loc } - -> - { - Ast_412.Parsetree.pdira_desc = - (copy_directive_argument_desc pdira_desc); - Ast_412.Parsetree.pdira_loc = (copy_location pdira_loc) - } -and copy_directive_argument_desc : - Ast_413.Parsetree.directive_argument_desc -> - Ast_412.Parsetree.directive_argument_desc - = - function - | Ast_413.Parsetree.Pdir_string x0 -> Ast_412.Parsetree.Pdir_string x0 - | Ast_413.Parsetree.Pdir_int (x0, x1) -> - Ast_412.Parsetree.Pdir_int (x0, (Option.map (fun x -> x) x1)) - | Ast_413.Parsetree.Pdir_ident x0 -> - Ast_412.Parsetree.Pdir_ident (copy_Longident_t x0) - | Ast_413.Parsetree.Pdir_bool x0 -> Ast_412.Parsetree.Pdir_bool x0 -and copy_expression : - Ast_413.Parsetree.expression -> Ast_412.Parsetree.expression = - fun - { Ast_413.Parsetree.pexp_desc = pexp_desc; - Ast_413.Parsetree.pexp_loc = pexp_loc; - Ast_413.Parsetree.pexp_loc_stack = pexp_loc_stack; - Ast_413.Parsetree.pexp_attributes = pexp_attributes } - -> - { - Ast_412.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - Ast_412.Parsetree.pexp_loc = (copy_location pexp_loc); - Ast_412.Parsetree.pexp_loc_stack = (copy_location_stack pexp_loc_stack); - Ast_412.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } -and copy_expression_desc : - Ast_413.Parsetree.expression_desc -> Ast_412.Parsetree.expression_desc = - function - | Ast_413.Parsetree.Pexp_ident x0 -> - Ast_412.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) - | Ast_413.Parsetree.Pexp_constant x0 -> - Ast_412.Parsetree.Pexp_constant (copy_constant x0) - | Ast_413.Parsetree.Pexp_let (x0, x1, x2) -> - Ast_412.Parsetree.Pexp_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_expression x2)) - | Ast_413.Parsetree.Pexp_function x0 -> - Ast_412.Parsetree.Pexp_function (List.map copy_case x0) - | Ast_413.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_412.Parsetree.Pexp_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_expression x3)) - | Ast_413.Parsetree.Pexp_apply (x0, x1) -> - Ast_412.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_413.Parsetree.Pexp_match (x0, x1) -> - Ast_412.Parsetree.Pexp_match - ((copy_expression x0), (List.map copy_case x1)) - | Ast_413.Parsetree.Pexp_try (x0, x1) -> - Ast_412.Parsetree.Pexp_try - ((copy_expression x0), (List.map copy_case x1)) - | Ast_413.Parsetree.Pexp_tuple x0 -> - Ast_412.Parsetree.Pexp_tuple (List.map copy_expression x0) - | Ast_413.Parsetree.Pexp_construct (x0, x1) -> - Ast_412.Parsetree.Pexp_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_expression x1)) - | Ast_413.Parsetree.Pexp_variant (x0, x1) -> - Ast_412.Parsetree.Pexp_variant - ((copy_label x0), (Option.map copy_expression x1)) - | Ast_413.Parsetree.Pexp_record (x0, x1) -> - Ast_412.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_expression x1))) x0), - (Option.map copy_expression x1)) - | Ast_413.Parsetree.Pexp_field (x0, x1) -> - Ast_412.Parsetree.Pexp_field - ((copy_expression x0), (copy_loc copy_Longident_t x1)) - | Ast_413.Parsetree.Pexp_setfield (x0, x1, x2) -> - Ast_412.Parsetree.Pexp_setfield - ((copy_expression x0), (copy_loc copy_Longident_t x1), - (copy_expression x2)) - | Ast_413.Parsetree.Pexp_array x0 -> - Ast_412.Parsetree.Pexp_array (List.map copy_expression x0) - | Ast_413.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> - Ast_412.Parsetree.Pexp_ifthenelse - ((copy_expression x0), (copy_expression x1), - (Option.map copy_expression x2)) - | Ast_413.Parsetree.Pexp_sequence (x0, x1) -> - Ast_412.Parsetree.Pexp_sequence - ((copy_expression x0), (copy_expression x1)) - | Ast_413.Parsetree.Pexp_while (x0, x1) -> - Ast_412.Parsetree.Pexp_while - ((copy_expression x0), (copy_expression x1)) - | Ast_413.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> - Ast_412.Parsetree.Pexp_for - ((copy_pattern x0), (copy_expression x1), (copy_expression x2), - (copy_direction_flag x3), (copy_expression x4)) - | Ast_413.Parsetree.Pexp_constraint (x0, x1) -> - Ast_412.Parsetree.Pexp_constraint - ((copy_expression x0), (copy_core_type x1)) - | Ast_413.Parsetree.Pexp_coerce (x0, x1, x2) -> - Ast_412.Parsetree.Pexp_coerce - ((copy_expression x0), (Option.map copy_core_type x1), - (copy_core_type x2)) - | Ast_413.Parsetree.Pexp_send (x0, x1) -> - Ast_412.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc copy_label x1)) - | Ast_413.Parsetree.Pexp_new x0 -> - Ast_412.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) - | Ast_413.Parsetree.Pexp_setinstvar (x0, x1) -> - Ast_412.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), (copy_expression x1)) - | Ast_413.Parsetree.Pexp_override x0 -> - Ast_412.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_label x0), (copy_expression x1))) x0) - | Ast_413.Parsetree.Pexp_letmodule (x0, x1, x2) -> - Ast_412.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_expr x1), (copy_expression x2)) - | Ast_413.Parsetree.Pexp_letexception (x0, x1) -> - Ast_412.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), (copy_expression x1)) - | Ast_413.Parsetree.Pexp_assert x0 -> - Ast_412.Parsetree.Pexp_assert (copy_expression x0) - | Ast_413.Parsetree.Pexp_lazy x0 -> - Ast_412.Parsetree.Pexp_lazy (copy_expression x0) - | Ast_413.Parsetree.Pexp_poly (x0, x1) -> - Ast_412.Parsetree.Pexp_poly - ((copy_expression x0), (Option.map copy_core_type x1)) - | Ast_413.Parsetree.Pexp_object x0 -> - Ast_412.Parsetree.Pexp_object (copy_class_structure x0) - | Ast_413.Parsetree.Pexp_newtype (x0, x1) -> - Ast_412.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | Ast_413.Parsetree.Pexp_pack x0 -> - Ast_412.Parsetree.Pexp_pack (copy_module_expr x0) - | Ast_413.Parsetree.Pexp_open (x0, x1) -> - Ast_412.Parsetree.Pexp_open - ((copy_open_declaration x0), (copy_expression x1)) - | Ast_413.Parsetree.Pexp_letop x0 -> - Ast_412.Parsetree.Pexp_letop (copy_letop x0) - | Ast_413.Parsetree.Pexp_extension x0 -> - Ast_412.Parsetree.Pexp_extension (copy_extension x0) - | Ast_413.Parsetree.Pexp_unreachable -> Ast_412.Parsetree.Pexp_unreachable -and copy_letop : Ast_413.Parsetree.letop -> Ast_412.Parsetree.letop = - fun - { Ast_413.Parsetree.let_ = let_; Ast_413.Parsetree.ands = ands; - Ast_413.Parsetree.body = body } - -> - { - Ast_412.Parsetree.let_ = (copy_binding_op let_); - Ast_412.Parsetree.ands = (List.map copy_binding_op ands); - Ast_412.Parsetree.body = (copy_expression body) - } -and copy_binding_op : - Ast_413.Parsetree.binding_op -> Ast_412.Parsetree.binding_op = - fun - { Ast_413.Parsetree.pbop_op = pbop_op; - Ast_413.Parsetree.pbop_pat = pbop_pat; - Ast_413.Parsetree.pbop_exp = pbop_exp; - Ast_413.Parsetree.pbop_loc = pbop_loc } - -> - { - Ast_412.Parsetree.pbop_op = (copy_loc (fun x -> x) pbop_op); - Ast_412.Parsetree.pbop_pat = (copy_pattern pbop_pat); - Ast_412.Parsetree.pbop_exp = (copy_expression pbop_exp); - Ast_412.Parsetree.pbop_loc = (copy_location pbop_loc) - } -and copy_direction_flag : - Ast_413.Asttypes.direction_flag -> Ast_412.Asttypes.direction_flag = - function - | Ast_413.Asttypes.Upto -> Ast_412.Asttypes.Upto - | Ast_413.Asttypes.Downto -> Ast_412.Asttypes.Downto -and copy_case : Ast_413.Parsetree.case -> Ast_412.Parsetree.case = - fun - { Ast_413.Parsetree.pc_lhs = pc_lhs; - Ast_413.Parsetree.pc_guard = pc_guard; - Ast_413.Parsetree.pc_rhs = pc_rhs } - -> - { - Ast_412.Parsetree.pc_lhs = (copy_pattern pc_lhs); - Ast_412.Parsetree.pc_guard = (Option.map copy_expression pc_guard); - Ast_412.Parsetree.pc_rhs = (copy_expression pc_rhs) - } -and copy_value_binding : - Ast_413.Parsetree.value_binding -> Ast_412.Parsetree.value_binding = - fun - { Ast_413.Parsetree.pvb_pat = pvb_pat; - Ast_413.Parsetree.pvb_expr = pvb_expr; - Ast_413.Parsetree.pvb_attributes = pvb_attributes; - Ast_413.Parsetree.pvb_loc = pvb_loc } - -> - { - Ast_412.Parsetree.pvb_pat = (copy_pattern pvb_pat); - Ast_412.Parsetree.pvb_expr = (copy_expression pvb_expr); - Ast_412.Parsetree.pvb_attributes = (copy_attributes pvb_attributes); - Ast_412.Parsetree.pvb_loc = (copy_location pvb_loc) - } -and copy_pattern : Ast_413.Parsetree.pattern -> Ast_412.Parsetree.pattern = - fun - { Ast_413.Parsetree.ppat_desc = ppat_desc; - Ast_413.Parsetree.ppat_loc = ppat_loc; - Ast_413.Parsetree.ppat_loc_stack = ppat_loc_stack; - Ast_413.Parsetree.ppat_attributes = ppat_attributes } - -> - { - Ast_412.Parsetree.ppat_desc = (copy_pattern_desc ppat_desc); - Ast_412.Parsetree.ppat_loc = (copy_location ppat_loc); - Ast_412.Parsetree.ppat_loc_stack = (copy_location_stack ppat_loc_stack); - Ast_412.Parsetree.ppat_attributes = (copy_attributes ppat_attributes) - } -and copy_pattern_desc : - Ast_413.Parsetree.pattern_desc -> Ast_412.Parsetree.pattern_desc = - function - | Ast_413.Parsetree.Ppat_any -> Ast_412.Parsetree.Ppat_any - | Ast_413.Parsetree.Ppat_var x0 -> - Ast_412.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | Ast_413.Parsetree.Ppat_alias (x0, x1) -> - Ast_412.Parsetree.Ppat_alias - ((copy_pattern x0), (copy_loc (fun x -> x) x1)) - | Ast_413.Parsetree.Ppat_constant x0 -> - Ast_412.Parsetree.Ppat_constant (copy_constant x0) - | Ast_413.Parsetree.Ppat_interval (x0, x1) -> - Ast_412.Parsetree.Ppat_interval - ((copy_constant x0), (copy_constant x1)) - | Ast_413.Parsetree.Ppat_tuple x0 -> - Ast_412.Parsetree.Ppat_tuple (List.map copy_pattern x0) - | Ast_413.Parsetree.Ppat_construct (x0, x1) -> - Ast_412.Parsetree.Ppat_construct - ((copy_loc copy_Longident_t x0), - (Option.map - (fun x -> - let (_, x1) = x in - copy_pattern x1) x1)) - | Ast_413.Parsetree.Ppat_variant (x0, x1) -> - Ast_412.Parsetree.Ppat_variant - ((copy_label x0), (Option.map copy_pattern x1)) - | Ast_413.Parsetree.Ppat_record (x0, x1) -> - Ast_412.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | Ast_413.Parsetree.Ppat_array x0 -> - Ast_412.Parsetree.Ppat_array (List.map copy_pattern x0) - | Ast_413.Parsetree.Ppat_or (x0, x1) -> - Ast_412.Parsetree.Ppat_or ((copy_pattern x0), (copy_pattern x1)) - | Ast_413.Parsetree.Ppat_constraint (x0, x1) -> - Ast_412.Parsetree.Ppat_constraint - ((copy_pattern x0), (copy_core_type x1)) - | Ast_413.Parsetree.Ppat_type x0 -> - Ast_412.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) - | Ast_413.Parsetree.Ppat_lazy x0 -> - Ast_412.Parsetree.Ppat_lazy (copy_pattern x0) - | Ast_413.Parsetree.Ppat_unpack x0 -> - Ast_412.Parsetree.Ppat_unpack - (copy_loc (fun x -> Option.map (fun x -> x) x) x0) - | Ast_413.Parsetree.Ppat_exception x0 -> - Ast_412.Parsetree.Ppat_exception (copy_pattern x0) - | Ast_413.Parsetree.Ppat_extension x0 -> - Ast_412.Parsetree.Ppat_extension (copy_extension x0) - | Ast_413.Parsetree.Ppat_open (x0, x1) -> - Ast_412.Parsetree.Ppat_open - ((copy_loc copy_Longident_t x0), (copy_pattern x1)) -and copy_core_type : - Ast_413.Parsetree.core_type -> Ast_412.Parsetree.core_type = - fun - { Ast_413.Parsetree.ptyp_desc = ptyp_desc; - Ast_413.Parsetree.ptyp_loc = ptyp_loc; - Ast_413.Parsetree.ptyp_loc_stack = ptyp_loc_stack; - Ast_413.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - Ast_412.Parsetree.ptyp_desc = (copy_core_type_desc ptyp_desc); - Ast_412.Parsetree.ptyp_loc = (copy_location ptyp_loc); - Ast_412.Parsetree.ptyp_loc_stack = (copy_location_stack ptyp_loc_stack); - Ast_412.Parsetree.ptyp_attributes = (copy_attributes ptyp_attributes) - } -and copy_location_stack : - Ast_413.Parsetree.location_stack -> Ast_412.Parsetree.location_stack = - fun x -> List.map copy_location x -and copy_core_type_desc : - Ast_413.Parsetree.core_type_desc -> Ast_412.Parsetree.core_type_desc = - function - | Ast_413.Parsetree.Ptyp_any -> Ast_412.Parsetree.Ptyp_any - | Ast_413.Parsetree.Ptyp_var x0 -> Ast_412.Parsetree.Ptyp_var x0 - | Ast_413.Parsetree.Ptyp_arrow (x0, x1, x2) -> - Ast_412.Parsetree.Ptyp_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_core_type x2)) - | Ast_413.Parsetree.Ptyp_tuple x0 -> - Ast_412.Parsetree.Ptyp_tuple (List.map copy_core_type x0) - | Ast_413.Parsetree.Ptyp_constr (x0, x1) -> - Ast_412.Parsetree.Ptyp_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_413.Parsetree.Ptyp_object (x0, x1) -> - Ast_412.Parsetree.Ptyp_object - ((List.map copy_object_field x0), (copy_closed_flag x1)) - | Ast_413.Parsetree.Ptyp_class (x0, x1) -> - Ast_412.Parsetree.Ptyp_class - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_413.Parsetree.Ptyp_alias (x0, x1) -> - Ast_412.Parsetree.Ptyp_alias ((copy_core_type x0), x1) - | Ast_413.Parsetree.Ptyp_variant (x0, x1, x2) -> - Ast_412.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), (copy_closed_flag x1), - (Option.map (fun x -> List.map copy_label x) x2)) - | Ast_413.Parsetree.Ptyp_poly (x0, x1) -> - Ast_412.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | Ast_413.Parsetree.Ptyp_package x0 -> - Ast_412.Parsetree.Ptyp_package (copy_package_type x0) - | Ast_413.Parsetree.Ptyp_extension x0 -> - Ast_412.Parsetree.Ptyp_extension (copy_extension x0) -and copy_package_type : - Ast_413.Parsetree.package_type -> Ast_412.Parsetree.package_type = - fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_core_type x1))) x1)) -and copy_row_field : - Ast_413.Parsetree.row_field -> Ast_412.Parsetree.row_field = - fun - { Ast_413.Parsetree.prf_desc = prf_desc; - Ast_413.Parsetree.prf_loc = prf_loc; - Ast_413.Parsetree.prf_attributes = prf_attributes } - -> - { - Ast_412.Parsetree.prf_desc = (copy_row_field_desc prf_desc); - Ast_412.Parsetree.prf_loc = (copy_location prf_loc); - Ast_412.Parsetree.prf_attributes = (copy_attributes prf_attributes) - } -and copy_row_field_desc : - Ast_413.Parsetree.row_field_desc -> Ast_412.Parsetree.row_field_desc = - function - | Ast_413.Parsetree.Rtag (x0, x1, x2) -> - Ast_412.Parsetree.Rtag - ((copy_loc copy_label x0), x1, (List.map copy_core_type x2)) - | Ast_413.Parsetree.Rinherit x0 -> - Ast_412.Parsetree.Rinherit (copy_core_type x0) -and copy_object_field : - Ast_413.Parsetree.object_field -> Ast_412.Parsetree.object_field = - fun - { Ast_413.Parsetree.pof_desc = pof_desc; - Ast_413.Parsetree.pof_loc = pof_loc; - Ast_413.Parsetree.pof_attributes = pof_attributes } - -> - { - Ast_412.Parsetree.pof_desc = (copy_object_field_desc pof_desc); - Ast_412.Parsetree.pof_loc = (copy_location pof_loc); - Ast_412.Parsetree.pof_attributes = (copy_attributes pof_attributes) - } -and copy_attributes : - Ast_413.Parsetree.attributes -> Ast_412.Parsetree.attributes = - fun x -> List.map copy_attribute x -and copy_attribute : - Ast_413.Parsetree.attribute -> Ast_412.Parsetree.attribute = - fun - { Ast_413.Parsetree.attr_name = attr_name; - Ast_413.Parsetree.attr_payload = attr_payload; - Ast_413.Parsetree.attr_loc = attr_loc } - -> - { - Ast_412.Parsetree.attr_name = (copy_loc (fun x -> x) attr_name); - Ast_412.Parsetree.attr_payload = (copy_payload attr_payload); - Ast_412.Parsetree.attr_loc = (copy_location attr_loc) - } -and copy_payload : Ast_413.Parsetree.payload -> Ast_412.Parsetree.payload = - function - | Ast_413.Parsetree.PStr x0 -> Ast_412.Parsetree.PStr (copy_structure x0) - | Ast_413.Parsetree.PSig x0 -> Ast_412.Parsetree.PSig (copy_signature x0) - | Ast_413.Parsetree.PTyp x0 -> Ast_412.Parsetree.PTyp (copy_core_type x0) - | Ast_413.Parsetree.PPat (x0, x1) -> - Ast_412.Parsetree.PPat - ((copy_pattern x0), (Option.map copy_expression x1)) -and copy_structure : - Ast_413.Parsetree.structure -> Ast_412.Parsetree.structure = - fun x -> List.map copy_structure_item x -and copy_structure_item : - Ast_413.Parsetree.structure_item -> Ast_412.Parsetree.structure_item = - fun - { Ast_413.Parsetree.pstr_desc = pstr_desc; - Ast_413.Parsetree.pstr_loc = pstr_loc } - -> - { - Ast_412.Parsetree.pstr_desc = (copy_structure_item_desc pstr_desc); - Ast_412.Parsetree.pstr_loc = (copy_location pstr_loc) - } -and copy_structure_item_desc : - Ast_413.Parsetree.structure_item_desc -> - Ast_412.Parsetree.structure_item_desc - = - function - | Ast_413.Parsetree.Pstr_eval (x0, x1) -> - Ast_412.Parsetree.Pstr_eval - ((copy_expression x0), (copy_attributes x1)) - | Ast_413.Parsetree.Pstr_value (x0, x1) -> - Ast_412.Parsetree.Pstr_value - ((copy_rec_flag x0), (List.map copy_value_binding x1)) - | Ast_413.Parsetree.Pstr_primitive x0 -> - Ast_412.Parsetree.Pstr_primitive (copy_value_description x0) - | Ast_413.Parsetree.Pstr_type (x0, x1) -> - Ast_412.Parsetree.Pstr_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_413.Parsetree.Pstr_typext x0 -> - Ast_412.Parsetree.Pstr_typext (copy_type_extension x0) - | Ast_413.Parsetree.Pstr_exception x0 -> - Ast_412.Parsetree.Pstr_exception (copy_type_exception x0) - | Ast_413.Parsetree.Pstr_module x0 -> - Ast_412.Parsetree.Pstr_module (copy_module_binding x0) - | Ast_413.Parsetree.Pstr_recmodule x0 -> - Ast_412.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) - | Ast_413.Parsetree.Pstr_modtype x0 -> - Ast_412.Parsetree.Pstr_modtype (copy_module_type_declaration x0) - | Ast_413.Parsetree.Pstr_open x0 -> - Ast_412.Parsetree.Pstr_open (copy_open_declaration x0) - | Ast_413.Parsetree.Pstr_class x0 -> - Ast_412.Parsetree.Pstr_class (List.map copy_class_declaration x0) - | Ast_413.Parsetree.Pstr_class_type x0 -> - Ast_412.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | Ast_413.Parsetree.Pstr_include x0 -> - Ast_412.Parsetree.Pstr_include (copy_include_declaration x0) - | Ast_413.Parsetree.Pstr_attribute x0 -> - Ast_412.Parsetree.Pstr_attribute (copy_attribute x0) - | Ast_413.Parsetree.Pstr_extension (x0, x1) -> - Ast_412.Parsetree.Pstr_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_include_declaration : - Ast_413.Parsetree.include_declaration -> - Ast_412.Parsetree.include_declaration - = fun x -> copy_include_infos copy_module_expr x -and copy_class_declaration : - Ast_413.Parsetree.class_declaration -> Ast_412.Parsetree.class_declaration - = fun x -> copy_class_infos copy_class_expr x -and copy_class_expr : - Ast_413.Parsetree.class_expr -> Ast_412.Parsetree.class_expr = - fun - { Ast_413.Parsetree.pcl_desc = pcl_desc; - Ast_413.Parsetree.pcl_loc = pcl_loc; - Ast_413.Parsetree.pcl_attributes = pcl_attributes } - -> - { - Ast_412.Parsetree.pcl_desc = (copy_class_expr_desc pcl_desc); - Ast_412.Parsetree.pcl_loc = (copy_location pcl_loc); - Ast_412.Parsetree.pcl_attributes = (copy_attributes pcl_attributes) - } -and copy_class_expr_desc : - Ast_413.Parsetree.class_expr_desc -> Ast_412.Parsetree.class_expr_desc = - function - | Ast_413.Parsetree.Pcl_constr (x0, x1) -> - Ast_412.Parsetree.Pcl_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_413.Parsetree.Pcl_structure x0 -> - Ast_412.Parsetree.Pcl_structure (copy_class_structure x0) - | Ast_413.Parsetree.Pcl_fun (x0, x1, x2, x3) -> - Ast_412.Parsetree.Pcl_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_class_expr x3)) - | Ast_413.Parsetree.Pcl_apply (x0, x1) -> - Ast_412.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_413.Parsetree.Pcl_let (x0, x1, x2) -> - Ast_412.Parsetree.Pcl_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_class_expr x2)) - | Ast_413.Parsetree.Pcl_constraint (x0, x1) -> - Ast_412.Parsetree.Pcl_constraint - ((copy_class_expr x0), (copy_class_type x1)) - | Ast_413.Parsetree.Pcl_extension x0 -> - Ast_412.Parsetree.Pcl_extension (copy_extension x0) - | Ast_413.Parsetree.Pcl_open (x0, x1) -> - Ast_412.Parsetree.Pcl_open - ((copy_open_description x0), (copy_class_expr x1)) -and copy_class_structure : - Ast_413.Parsetree.class_structure -> Ast_412.Parsetree.class_structure = - fun - { Ast_413.Parsetree.pcstr_self = pcstr_self; - Ast_413.Parsetree.pcstr_fields = pcstr_fields } - -> - { - Ast_412.Parsetree.pcstr_self = (copy_pattern pcstr_self); - Ast_412.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } -and copy_class_field : - Ast_413.Parsetree.class_field -> Ast_412.Parsetree.class_field = - fun - { Ast_413.Parsetree.pcf_desc = pcf_desc; - Ast_413.Parsetree.pcf_loc = pcf_loc; - Ast_413.Parsetree.pcf_attributes = pcf_attributes } - -> - { - Ast_412.Parsetree.pcf_desc = (copy_class_field_desc pcf_desc); - Ast_412.Parsetree.pcf_loc = (copy_location pcf_loc); - Ast_412.Parsetree.pcf_attributes = (copy_attributes pcf_attributes) - } -and copy_class_field_desc : - Ast_413.Parsetree.class_field_desc -> Ast_412.Parsetree.class_field_desc = - function - | Ast_413.Parsetree.Pcf_inherit (x0, x1, x2) -> - Ast_412.Parsetree.Pcf_inherit - ((copy_override_flag x0), (copy_class_expr x1), - (Option.map (fun x -> copy_loc (fun x -> x) x) x2)) - | Ast_413.Parsetree.Pcf_val x0 -> - Ast_412.Parsetree.Pcf_val - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | Ast_413.Parsetree.Pcf_method x0 -> - Ast_412.Parsetree.Pcf_method - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_class_field_kind x2))) - | Ast_413.Parsetree.Pcf_constraint x0 -> - Ast_412.Parsetree.Pcf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_413.Parsetree.Pcf_initializer x0 -> - Ast_412.Parsetree.Pcf_initializer (copy_expression x0) - | Ast_413.Parsetree.Pcf_attribute x0 -> - Ast_412.Parsetree.Pcf_attribute (copy_attribute x0) - | Ast_413.Parsetree.Pcf_extension x0 -> - Ast_412.Parsetree.Pcf_extension (copy_extension x0) -and copy_class_field_kind : - Ast_413.Parsetree.class_field_kind -> Ast_412.Parsetree.class_field_kind = - function - | Ast_413.Parsetree.Cfk_virtual x0 -> - Ast_412.Parsetree.Cfk_virtual (copy_core_type x0) - | Ast_413.Parsetree.Cfk_concrete (x0, x1) -> - Ast_412.Parsetree.Cfk_concrete - ((copy_override_flag x0), (copy_expression x1)) -and copy_open_declaration : - Ast_413.Parsetree.open_declaration -> Ast_412.Parsetree.open_declaration = - fun x -> copy_open_infos copy_module_expr x -and copy_module_binding : - Ast_413.Parsetree.module_binding -> Ast_412.Parsetree.module_binding = - fun - { Ast_413.Parsetree.pmb_name = pmb_name; - Ast_413.Parsetree.pmb_expr = pmb_expr; - Ast_413.Parsetree.pmb_attributes = pmb_attributes; - Ast_413.Parsetree.pmb_loc = pmb_loc } - -> - { - Ast_412.Parsetree.pmb_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name); - Ast_412.Parsetree.pmb_expr = (copy_module_expr pmb_expr); - Ast_412.Parsetree.pmb_attributes = (copy_attributes pmb_attributes); - Ast_412.Parsetree.pmb_loc = (copy_location pmb_loc) - } -and copy_module_expr : - Ast_413.Parsetree.module_expr -> Ast_412.Parsetree.module_expr = - fun - { Ast_413.Parsetree.pmod_desc = pmod_desc; - Ast_413.Parsetree.pmod_loc = pmod_loc; - Ast_413.Parsetree.pmod_attributes = pmod_attributes } - -> - { - Ast_412.Parsetree.pmod_desc = (copy_module_expr_desc pmod_desc); - Ast_412.Parsetree.pmod_loc = (copy_location pmod_loc); - Ast_412.Parsetree.pmod_attributes = (copy_attributes pmod_attributes) - } -and copy_module_expr_desc : - Ast_413.Parsetree.module_expr_desc -> Ast_412.Parsetree.module_expr_desc = - function - | Ast_413.Parsetree.Pmod_ident x0 -> - Ast_412.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) - | Ast_413.Parsetree.Pmod_structure x0 -> - Ast_412.Parsetree.Pmod_structure (copy_structure x0) - | Ast_413.Parsetree.Pmod_functor (x0, x1) -> - Ast_412.Parsetree.Pmod_functor - ((copy_functor_parameter x0), (copy_module_expr x1)) - | Ast_413.Parsetree.Pmod_apply (x0, x1) -> - Ast_412.Parsetree.Pmod_apply - ((copy_module_expr x0), (copy_module_expr x1)) - | Ast_413.Parsetree.Pmod_constraint (x0, x1) -> - Ast_412.Parsetree.Pmod_constraint - ((copy_module_expr x0), (copy_module_type x1)) - | Ast_413.Parsetree.Pmod_unpack x0 -> - Ast_412.Parsetree.Pmod_unpack (copy_expression x0) - | Ast_413.Parsetree.Pmod_extension x0 -> - Ast_412.Parsetree.Pmod_extension (copy_extension x0) -and copy_functor_parameter : - Ast_413.Parsetree.functor_parameter -> Ast_412.Parsetree.functor_parameter - = - function - | Ast_413.Parsetree.Unit -> Ast_412.Parsetree.Unit - | Ast_413.Parsetree.Named (x0, x1) -> - Ast_412.Parsetree.Named - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_type x1)) -and copy_module_type : - Ast_413.Parsetree.module_type -> Ast_412.Parsetree.module_type = - fun - { Ast_413.Parsetree.pmty_desc = pmty_desc; - Ast_413.Parsetree.pmty_loc = pmty_loc; - Ast_413.Parsetree.pmty_attributes = pmty_attributes } - -> - { - Ast_412.Parsetree.pmty_desc = (copy_module_type_desc pmty_desc); - Ast_412.Parsetree.pmty_loc = (copy_location pmty_loc); - Ast_412.Parsetree.pmty_attributes = (copy_attributes pmty_attributes) - } -and copy_module_type_desc : - Ast_413.Parsetree.module_type_desc -> Ast_412.Parsetree.module_type_desc = - function - | Ast_413.Parsetree.Pmty_ident x0 -> - Ast_412.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) - | Ast_413.Parsetree.Pmty_signature x0 -> - Ast_412.Parsetree.Pmty_signature (copy_signature x0) - | Ast_413.Parsetree.Pmty_functor (x0, x1) -> - Ast_412.Parsetree.Pmty_functor - ((copy_functor_parameter x0), (copy_module_type x1)) - | Ast_413.Parsetree.Pmty_with (x0, x1) -> - Ast_412.Parsetree.Pmty_with - ((copy_module_type x0), (List.map copy_with_constraint x1)) - | Ast_413.Parsetree.Pmty_typeof x0 -> - Ast_412.Parsetree.Pmty_typeof (copy_module_expr x0) - | Ast_413.Parsetree.Pmty_extension x0 -> - Ast_412.Parsetree.Pmty_extension (copy_extension x0) - | Ast_413.Parsetree.Pmty_alias x0 -> - Ast_412.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) -and copy_with_constraint : - Ast_413.Parsetree.with_constraint -> Ast_412.Parsetree.with_constraint = - function - | Ast_413.Parsetree.Pwith_type (x0, x1) -> - Ast_412.Parsetree.Pwith_type - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_413.Parsetree.Pwith_module (x0, x1) -> - Ast_412.Parsetree.Pwith_module - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) - | Ast_413.Parsetree.Pwith_modtype (_, x1) -> - migration_error x1.Ast_413.Parsetree.pmty_loc With_modtype - | Ast_413.Parsetree.Pwith_modtypesubst (_, x1) -> - migration_error x1.Ast_413.Parsetree.pmty_loc With_modtypesubst - | Ast_413.Parsetree.Pwith_typesubst (x0, x1) -> - Ast_412.Parsetree.Pwith_typesubst - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_413.Parsetree.Pwith_modsubst (x0, x1) -> - Ast_412.Parsetree.Pwith_modsubst - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) -and copy_signature : - Ast_413.Parsetree.signature -> Ast_412.Parsetree.signature = - fun x -> List.map copy_signature_item x -and copy_signature_item : - Ast_413.Parsetree.signature_item -> Ast_412.Parsetree.signature_item = - fun - { Ast_413.Parsetree.psig_desc = psig_desc; - Ast_413.Parsetree.psig_loc = psig_loc } - -> - { - Ast_412.Parsetree.psig_desc = (copy_signature_item_desc psig_desc); - Ast_412.Parsetree.psig_loc = (copy_location psig_loc) - } -and copy_signature_item_desc : - Ast_413.Parsetree.signature_item_desc -> - Ast_412.Parsetree.signature_item_desc - = - function - | Ast_413.Parsetree.Psig_value x0 -> - Ast_412.Parsetree.Psig_value (copy_value_description x0) - | Ast_413.Parsetree.Psig_type (x0, x1) -> - Ast_412.Parsetree.Psig_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_413.Parsetree.Psig_typesubst x0 -> - Ast_412.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) - | Ast_413.Parsetree.Psig_typext x0 -> - Ast_412.Parsetree.Psig_typext (copy_type_extension x0) - | Ast_413.Parsetree.Psig_exception x0 -> - Ast_412.Parsetree.Psig_exception (copy_type_exception x0) - | Ast_413.Parsetree.Psig_module x0 -> - Ast_412.Parsetree.Psig_module (copy_module_declaration x0) - | Ast_413.Parsetree.Psig_modsubst x0 -> - Ast_412.Parsetree.Psig_modsubst (copy_module_substitution x0) - | Ast_413.Parsetree.Psig_recmodule x0 -> - Ast_412.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) - | Ast_413.Parsetree.Psig_modtype x0 -> - Ast_412.Parsetree.Psig_modtype (copy_module_type_declaration x0) - | Ast_413.Parsetree.Psig_modtypesubst x0 -> - migration_error x0.Ast_413.Parsetree.pmtd_loc Psig_modtypesubst - | Ast_413.Parsetree.Psig_open x0 -> - Ast_412.Parsetree.Psig_open (copy_open_description x0) - | Ast_413.Parsetree.Psig_include x0 -> - Ast_412.Parsetree.Psig_include (copy_include_description x0) - | Ast_413.Parsetree.Psig_class x0 -> - Ast_412.Parsetree.Psig_class (List.map copy_class_description x0) - | Ast_413.Parsetree.Psig_class_type x0 -> - Ast_412.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | Ast_413.Parsetree.Psig_attribute x0 -> - Ast_412.Parsetree.Psig_attribute (copy_attribute x0) - | Ast_413.Parsetree.Psig_extension (x0, x1) -> - Ast_412.Parsetree.Psig_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_class_type_declaration : - Ast_413.Parsetree.class_type_declaration -> - Ast_412.Parsetree.class_type_declaration - = fun x -> copy_class_infos copy_class_type x -and copy_class_description : - Ast_413.Parsetree.class_description -> Ast_412.Parsetree.class_description - = fun x -> copy_class_infos copy_class_type x -and copy_class_type : - Ast_413.Parsetree.class_type -> Ast_412.Parsetree.class_type = - fun - { Ast_413.Parsetree.pcty_desc = pcty_desc; - Ast_413.Parsetree.pcty_loc = pcty_loc; - Ast_413.Parsetree.pcty_attributes = pcty_attributes } - -> - { - Ast_412.Parsetree.pcty_desc = (copy_class_type_desc pcty_desc); - Ast_412.Parsetree.pcty_loc = (copy_location pcty_loc); - Ast_412.Parsetree.pcty_attributes = (copy_attributes pcty_attributes) - } -and copy_class_type_desc : - Ast_413.Parsetree.class_type_desc -> Ast_412.Parsetree.class_type_desc = - function - | Ast_413.Parsetree.Pcty_constr (x0, x1) -> - Ast_412.Parsetree.Pcty_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_413.Parsetree.Pcty_signature x0 -> - Ast_412.Parsetree.Pcty_signature (copy_class_signature x0) - | Ast_413.Parsetree.Pcty_arrow (x0, x1, x2) -> - Ast_412.Parsetree.Pcty_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_class_type x2)) - | Ast_413.Parsetree.Pcty_extension x0 -> - Ast_412.Parsetree.Pcty_extension (copy_extension x0) - | Ast_413.Parsetree.Pcty_open (x0, x1) -> - Ast_412.Parsetree.Pcty_open - ((copy_open_description x0), (copy_class_type x1)) -and copy_class_signature : - Ast_413.Parsetree.class_signature -> Ast_412.Parsetree.class_signature = - fun - { Ast_413.Parsetree.pcsig_self = pcsig_self; - Ast_413.Parsetree.pcsig_fields = pcsig_fields } - -> - { - Ast_412.Parsetree.pcsig_self = (copy_core_type pcsig_self); - Ast_412.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } -and copy_class_type_field : - Ast_413.Parsetree.class_type_field -> Ast_412.Parsetree.class_type_field = - fun - { Ast_413.Parsetree.pctf_desc = pctf_desc; - Ast_413.Parsetree.pctf_loc = pctf_loc; - Ast_413.Parsetree.pctf_attributes = pctf_attributes } - -> - { - Ast_412.Parsetree.pctf_desc = (copy_class_type_field_desc pctf_desc); - Ast_412.Parsetree.pctf_loc = (copy_location pctf_loc); - Ast_412.Parsetree.pctf_attributes = (copy_attributes pctf_attributes) - } -and copy_class_type_field_desc : - Ast_413.Parsetree.class_type_field_desc -> - Ast_412.Parsetree.class_type_field_desc - = - function - | Ast_413.Parsetree.Pctf_inherit x0 -> - Ast_412.Parsetree.Pctf_inherit (copy_class_type x0) - | Ast_413.Parsetree.Pctf_val x0 -> - Ast_412.Parsetree.Pctf_val - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_413.Parsetree.Pctf_method x0 -> - Ast_412.Parsetree.Pctf_method - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_413.Parsetree.Pctf_constraint x0 -> - Ast_412.Parsetree.Pctf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_413.Parsetree.Pctf_attribute x0 -> - Ast_412.Parsetree.Pctf_attribute (copy_attribute x0) - | Ast_413.Parsetree.Pctf_extension x0 -> - Ast_412.Parsetree.Pctf_extension (copy_extension x0) -and copy_extension : - Ast_413.Parsetree.extension -> Ast_412.Parsetree.extension = - fun x -> - let (x0, x1) = x in ((copy_loc (fun x -> x) x0), (copy_payload x1)) -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_413.Parsetree.class_infos -> 'g0 Ast_412.Parsetree.class_infos - = - fun f0 -> - fun - { Ast_413.Parsetree.pci_virt = pci_virt; - Ast_413.Parsetree.pci_params = pci_params; - Ast_413.Parsetree.pci_name = pci_name; - Ast_413.Parsetree.pci_expr = pci_expr; - Ast_413.Parsetree.pci_loc = pci_loc; - Ast_413.Parsetree.pci_attributes = pci_attributes } - -> - { - Ast_412.Parsetree.pci_virt = (copy_virtual_flag pci_virt); - Ast_412.Parsetree.pci_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) pci_params); - Ast_412.Parsetree.pci_name = (copy_loc (fun x -> x) pci_name); - Ast_412.Parsetree.pci_expr = (f0 pci_expr); - Ast_412.Parsetree.pci_loc = (copy_location pci_loc); - Ast_412.Parsetree.pci_attributes = (copy_attributes pci_attributes) - } -and copy_virtual_flag : - Ast_413.Asttypes.virtual_flag -> Ast_412.Asttypes.virtual_flag = - function - | Ast_413.Asttypes.Virtual -> Ast_412.Asttypes.Virtual - | Ast_413.Asttypes.Concrete -> Ast_412.Asttypes.Concrete -and copy_include_description : - Ast_413.Parsetree.include_description -> - Ast_412.Parsetree.include_description - = fun x -> copy_include_infos copy_module_type x -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_413.Parsetree.include_infos -> - 'g0 Ast_412.Parsetree.include_infos - = - fun f0 -> - fun - { Ast_413.Parsetree.pincl_mod = pincl_mod; - Ast_413.Parsetree.pincl_loc = pincl_loc; - Ast_413.Parsetree.pincl_attributes = pincl_attributes } - -> - { - Ast_412.Parsetree.pincl_mod = (f0 pincl_mod); - Ast_412.Parsetree.pincl_loc = (copy_location pincl_loc); - Ast_412.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } -and copy_open_description : - Ast_413.Parsetree.open_description -> Ast_412.Parsetree.open_description = - fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x -and copy_open_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_413.Parsetree.open_infos -> 'g0 Ast_412.Parsetree.open_infos - = - fun f0 -> - fun - { Ast_413.Parsetree.popen_expr = popen_expr; - Ast_413.Parsetree.popen_override = popen_override; - Ast_413.Parsetree.popen_loc = popen_loc; - Ast_413.Parsetree.popen_attributes = popen_attributes } - -> - { - Ast_412.Parsetree.popen_expr = (f0 popen_expr); - Ast_412.Parsetree.popen_override = - (copy_override_flag popen_override); - Ast_412.Parsetree.popen_loc = (copy_location popen_loc); - Ast_412.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } -and copy_override_flag : - Ast_413.Asttypes.override_flag -> Ast_412.Asttypes.override_flag = - function - | Ast_413.Asttypes.Override -> Ast_412.Asttypes.Override - | Ast_413.Asttypes.Fresh -> Ast_412.Asttypes.Fresh -and copy_module_type_declaration : - Ast_413.Parsetree.module_type_declaration -> - Ast_412.Parsetree.module_type_declaration - = - fun - { Ast_413.Parsetree.pmtd_name = pmtd_name; - Ast_413.Parsetree.pmtd_type = pmtd_type; - Ast_413.Parsetree.pmtd_attributes = pmtd_attributes; - Ast_413.Parsetree.pmtd_loc = pmtd_loc } - -> - { - Ast_412.Parsetree.pmtd_name = (copy_loc (fun x -> x) pmtd_name); - Ast_412.Parsetree.pmtd_type = (Option.map copy_module_type pmtd_type); - Ast_412.Parsetree.pmtd_attributes = (copy_attributes pmtd_attributes); - Ast_412.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } -and copy_module_substitution : - Ast_413.Parsetree.module_substitution -> - Ast_412.Parsetree.module_substitution - = - fun - { Ast_413.Parsetree.pms_name = pms_name; - Ast_413.Parsetree.pms_manifest = pms_manifest; - Ast_413.Parsetree.pms_attributes = pms_attributes; - Ast_413.Parsetree.pms_loc = pms_loc } - -> - { - Ast_412.Parsetree.pms_name = (copy_loc (fun x -> x) pms_name); - Ast_412.Parsetree.pms_manifest = - (copy_loc copy_Longident_t pms_manifest); - Ast_412.Parsetree.pms_attributes = (copy_attributes pms_attributes); - Ast_412.Parsetree.pms_loc = (copy_location pms_loc) - } -and copy_module_declaration : - Ast_413.Parsetree.module_declaration -> - Ast_412.Parsetree.module_declaration - = - fun - { Ast_413.Parsetree.pmd_name = pmd_name; - Ast_413.Parsetree.pmd_type = pmd_type; - Ast_413.Parsetree.pmd_attributes = pmd_attributes; - Ast_413.Parsetree.pmd_loc = pmd_loc } - -> - { - Ast_412.Parsetree.pmd_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name); - Ast_412.Parsetree.pmd_type = (copy_module_type pmd_type); - Ast_412.Parsetree.pmd_attributes = (copy_attributes pmd_attributes); - Ast_412.Parsetree.pmd_loc = (copy_location pmd_loc) - } -and copy_type_exception : - Ast_413.Parsetree.type_exception -> Ast_412.Parsetree.type_exception = - fun - { Ast_413.Parsetree.ptyexn_constructor = ptyexn_constructor; - Ast_413.Parsetree.ptyexn_loc = ptyexn_loc; - Ast_413.Parsetree.ptyexn_attributes = ptyexn_attributes } - -> - { - Ast_412.Parsetree.ptyexn_constructor = - (copy_extension_constructor ptyexn_constructor); - Ast_412.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); - Ast_412.Parsetree.ptyexn_attributes = - (copy_attributes ptyexn_attributes) - } -and copy_type_extension : - Ast_413.Parsetree.type_extension -> Ast_412.Parsetree.type_extension = - fun - { Ast_413.Parsetree.ptyext_path = ptyext_path; - Ast_413.Parsetree.ptyext_params = ptyext_params; - Ast_413.Parsetree.ptyext_constructors = ptyext_constructors; - Ast_413.Parsetree.ptyext_private = ptyext_private; - Ast_413.Parsetree.ptyext_loc = ptyext_loc; - Ast_413.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - Ast_412.Parsetree.ptyext_path = (copy_loc copy_Longident_t ptyext_path); - Ast_412.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) ptyext_params); - Ast_412.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor ptyext_constructors); - Ast_412.Parsetree.ptyext_private = (copy_private_flag ptyext_private); - Ast_412.Parsetree.ptyext_loc = (copy_location ptyext_loc); - Ast_412.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } -and copy_extension_constructor : - Ast_413.Parsetree.extension_constructor -> - Ast_412.Parsetree.extension_constructor - = - fun - { Ast_413.Parsetree.pext_name = pext_name; - Ast_413.Parsetree.pext_kind = pext_kind; - Ast_413.Parsetree.pext_loc = pext_loc; - Ast_413.Parsetree.pext_attributes = pext_attributes } - -> - { - Ast_412.Parsetree.pext_name = (copy_loc (fun x -> x) pext_name); - Ast_412.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - Ast_412.Parsetree.pext_loc = (copy_location pext_loc); - Ast_412.Parsetree.pext_attributes = (copy_attributes pext_attributes) - } -and copy_extension_constructor_kind : - Ast_413.Parsetree.extension_constructor_kind -> - Ast_412.Parsetree.extension_constructor_kind - = - function - | Ast_413.Parsetree.Pext_decl (x0, x1) -> - Ast_412.Parsetree.Pext_decl - ((copy_constructor_arguments x0), (Option.map copy_core_type x1)) - | Ast_413.Parsetree.Pext_rebind x0 -> - Ast_412.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) -and copy_type_declaration : - Ast_413.Parsetree.type_declaration -> Ast_412.Parsetree.type_declaration = - fun - { Ast_413.Parsetree.ptype_name = ptype_name; - Ast_413.Parsetree.ptype_params = ptype_params; - Ast_413.Parsetree.ptype_cstrs = ptype_cstrs; - Ast_413.Parsetree.ptype_kind = ptype_kind; - Ast_413.Parsetree.ptype_private = ptype_private; - Ast_413.Parsetree.ptype_manifest = ptype_manifest; - Ast_413.Parsetree.ptype_attributes = ptype_attributes; - Ast_413.Parsetree.ptype_loc = ptype_loc } - -> - { - Ast_412.Parsetree.ptype_name = (copy_loc (fun x -> x) ptype_name); - Ast_412.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) ptype_params); - Ast_412.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0, x1, x2) = x in - ((copy_core_type x0), (copy_core_type x1), (copy_location x2))) - ptype_cstrs); - Ast_412.Parsetree.ptype_kind = (copy_type_kind ptype_kind); - Ast_412.Parsetree.ptype_private = (copy_private_flag ptype_private); - Ast_412.Parsetree.ptype_manifest = - (Option.map copy_core_type ptype_manifest); - Ast_412.Parsetree.ptype_attributes = (copy_attributes ptype_attributes); - Ast_412.Parsetree.ptype_loc = (copy_location ptype_loc) - } -and copy_private_flag : - Ast_413.Asttypes.private_flag -> Ast_412.Asttypes.private_flag = - function - | Ast_413.Asttypes.Private -> Ast_412.Asttypes.Private - | Ast_413.Asttypes.Public -> Ast_412.Asttypes.Public -and copy_type_kind : - Ast_413.Parsetree.type_kind -> Ast_412.Parsetree.type_kind = - function - | Ast_413.Parsetree.Ptype_abstract -> Ast_412.Parsetree.Ptype_abstract - | Ast_413.Parsetree.Ptype_variant x0 -> - Ast_412.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | Ast_413.Parsetree.Ptype_record x0 -> - Ast_412.Parsetree.Ptype_record (List.map copy_label_declaration x0) - | Ast_413.Parsetree.Ptype_open -> Ast_412.Parsetree.Ptype_open -and copy_constructor_declaration : - Ast_413.Parsetree.constructor_declaration -> - Ast_412.Parsetree.constructor_declaration - = - fun - { Ast_413.Parsetree.pcd_name = pcd_name; - Ast_413.Parsetree.pcd_args = pcd_args; - Ast_413.Parsetree.pcd_res = pcd_res; - Ast_413.Parsetree.pcd_loc = pcd_loc; - Ast_413.Parsetree.pcd_attributes = pcd_attributes } - -> - { - Ast_412.Parsetree.pcd_name = (copy_loc (fun x -> x) pcd_name); - Ast_412.Parsetree.pcd_args = (copy_constructor_arguments pcd_args); - Ast_412.Parsetree.pcd_res = (Option.map copy_core_type pcd_res); - Ast_412.Parsetree.pcd_loc = (copy_location pcd_loc); - Ast_412.Parsetree.pcd_attributes = (copy_attributes pcd_attributes) - } -and copy_constructor_arguments : - Ast_413.Parsetree.constructor_arguments -> - Ast_412.Parsetree.constructor_arguments - = - function - | Ast_413.Parsetree.Pcstr_tuple x0 -> - Ast_412.Parsetree.Pcstr_tuple (List.map copy_core_type x0) - | Ast_413.Parsetree.Pcstr_record x0 -> - Ast_412.Parsetree.Pcstr_record (List.map copy_label_declaration x0) -and copy_label_declaration : - Ast_413.Parsetree.label_declaration -> Ast_412.Parsetree.label_declaration - = - fun - { Ast_413.Parsetree.pld_name = pld_name; - Ast_413.Parsetree.pld_mutable = pld_mutable; - Ast_413.Parsetree.pld_type = pld_type; - Ast_413.Parsetree.pld_loc = pld_loc; - Ast_413.Parsetree.pld_attributes = pld_attributes } - -> - { - Ast_412.Parsetree.pld_name = (copy_loc (fun x -> x) pld_name); - Ast_412.Parsetree.pld_mutable = (copy_mutable_flag pld_mutable); - Ast_412.Parsetree.pld_type = (copy_core_type pld_type); - Ast_412.Parsetree.pld_loc = (copy_location pld_loc); - Ast_412.Parsetree.pld_attributes = (copy_attributes pld_attributes) - } -and copy_mutable_flag : - Ast_413.Asttypes.mutable_flag -> Ast_412.Asttypes.mutable_flag = - function - | Ast_413.Asttypes.Immutable -> Ast_412.Asttypes.Immutable - | Ast_413.Asttypes.Mutable -> Ast_412.Asttypes.Mutable -and copy_injectivity : - Ast_413.Asttypes.injectivity -> Ast_412.Asttypes.injectivity = - function - | Ast_413.Asttypes.Injective -> Ast_412.Asttypes.Injective - | Ast_413.Asttypes.NoInjectivity -> Ast_412.Asttypes.NoInjectivity -and copy_variance : Ast_413.Asttypes.variance -> Ast_412.Asttypes.variance = - function - | Ast_413.Asttypes.Covariant -> Ast_412.Asttypes.Covariant - | Ast_413.Asttypes.Contravariant -> Ast_412.Asttypes.Contravariant - | Ast_413.Asttypes.NoVariance -> Ast_412.Asttypes.NoVariance -and copy_value_description : - Ast_413.Parsetree.value_description -> Ast_412.Parsetree.value_description - = - fun - { Ast_413.Parsetree.pval_name = pval_name; - Ast_413.Parsetree.pval_type = pval_type; - Ast_413.Parsetree.pval_prim = pval_prim; - Ast_413.Parsetree.pval_attributes = pval_attributes; - Ast_413.Parsetree.pval_loc = pval_loc } - -> - { - Ast_412.Parsetree.pval_name = (copy_loc (fun x -> x) pval_name); - Ast_412.Parsetree.pval_type = (copy_core_type pval_type); - Ast_412.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - Ast_412.Parsetree.pval_attributes = (copy_attributes pval_attributes); - Ast_412.Parsetree.pval_loc = (copy_location pval_loc) - } -and copy_object_field_desc : - Ast_413.Parsetree.object_field_desc -> Ast_412.Parsetree.object_field_desc - = - function - | Ast_413.Parsetree.Otag (x0, x1) -> - Ast_412.Parsetree.Otag ((copy_loc copy_label x0), (copy_core_type x1)) - | Ast_413.Parsetree.Oinherit x0 -> - Ast_412.Parsetree.Oinherit (copy_core_type x0) -and copy_arg_label : Ast_413.Asttypes.arg_label -> Ast_412.Asttypes.arg_label - = - function - | Ast_413.Asttypes.Nolabel -> Ast_412.Asttypes.Nolabel - | Ast_413.Asttypes.Labelled x0 -> Ast_412.Asttypes.Labelled x0 - | Ast_413.Asttypes.Optional x0 -> Ast_412.Asttypes.Optional x0 -and copy_closed_flag : - Ast_413.Asttypes.closed_flag -> Ast_412.Asttypes.closed_flag = - function - | Ast_413.Asttypes.Closed -> Ast_412.Asttypes.Closed - | Ast_413.Asttypes.Open -> Ast_412.Asttypes.Open -and copy_label : Ast_413.Asttypes.label -> Ast_412.Asttypes.label = - fun x -> x -and copy_rec_flag : Ast_413.Asttypes.rec_flag -> Ast_412.Asttypes.rec_flag = - function - | Ast_413.Asttypes.Nonrecursive -> Ast_412.Asttypes.Nonrecursive - | Ast_413.Asttypes.Recursive -> Ast_412.Asttypes.Recursive -and copy_constant : Ast_413.Parsetree.constant -> Ast_412.Parsetree.constant - = - function - | Ast_413.Parsetree.Pconst_integer (x0, x1) -> - Ast_412.Parsetree.Pconst_integer (x0, (Option.map (fun x -> x) x1)) - | Ast_413.Parsetree.Pconst_char x0 -> Ast_412.Parsetree.Pconst_char x0 - | Ast_413.Parsetree.Pconst_string (x0, x1, x2) -> - Ast_412.Parsetree.Pconst_string - (x0, (copy_location x1), (Option.map (fun x -> x) x2)) - | Ast_413.Parsetree.Pconst_float (x0, x1) -> - Ast_412.Parsetree.Pconst_float (x0, (Option.map (fun x -> x) x1)) -and copy_Longident_t : Longident.t -> Longident.t = - function - | Longident.Lident x0 -> Longident.Lident x0 - | Longident.Ldot (x0, x1) -> Longident.Ldot ((copy_Longident_t x0), x1) - | Longident.Lapply (x0, x1) -> - Longident.Lapply ((copy_Longident_t x0), (copy_Longident_t x1)) -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 Ast_413.Asttypes.loc -> 'g0 Ast_412.Asttypes.loc - = - fun f0 -> - fun { Ast_413.Asttypes.txt = txt; Ast_413.Asttypes.loc = loc } -> - { - Ast_412.Asttypes.txt = (f0 txt); - Ast_412.Asttypes.loc = (copy_location loc) - } -and copy_location : Location.t -> Location.t = - fun - { Location.loc_start = loc_start; Location.loc_end = loc_end; - Location.loc_ghost = loc_ghost } - -> - { - Location.loc_start = (copy_position loc_start); - Location.loc_end = (copy_position loc_end); - Location.loc_ghost = loc_ghost - } -and copy_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum - } diff --git a/src/vendored-omp/src/migrate_parsetree_413_414.ml b/src/vendored-omp/src/migrate_parsetree_413_414.ml index b52be0951..82eed13e2 100644 --- a/src/vendored-omp/src/migrate_parsetree_413_414.ml +++ b/src/vendored-omp/src/migrate_parsetree_413_414.ml @@ -15,130 +15,3 @@ include Migrate_parsetree_413_414_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload"; - "binding_op"; "module_substitution"; "open_declaration"; "type_exception"; - "constant" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - binding_op; - module_substitution; - open_declaration; - type_exception; - constant; - (*$*) - } as mapper) -> - let module Def = Migrate_parsetree_def in - let module R = Migrate_parsetree_414_413_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> List.map copy_case (cases mapper (List.map R.copy_case x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expression (expr mapper (R.copy_expression x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pattern (pat mapper (R.copy_pattern x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_core_type (typ mapper (R.copy_core_type x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - binding_op = (fun _ x -> copy_binding_op (binding_op mapper (R.copy_binding_op x))); - module_substitution = (fun _ x -> copy_module_substitution (module_substitution mapper (R.copy_module_substitution x))); - open_declaration = (fun _ x -> copy_open_declaration (open_declaration mapper (R.copy_open_declaration x))); - type_exception = (fun _ x -> copy_type_exception (type_exception mapper (R.copy_type_exception x))); - constant = (fun _ x -> copy_constant (constant mapper (R.copy_constant x))); - (*$*) - } - diff --git a/src/vendored-omp/src/migrate_parsetree_413_414_migrate.ml b/src/vendored-omp/src/migrate_parsetree_413_414_migrate.ml index 6ebac11f9..cd52b9422 100644 --- a/src/vendored-omp/src/migrate_parsetree_413_414_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_413_414_migrate.ml @@ -158,6 +158,11 @@ and copy_out_extension_constructor : (Option.map copy_out_type oext_ret_type); Ast_414.Outcometree.oext_private = (copy_private_flag oext_private) } +and copy_private_flag : + Ast_413.Asttypes.private_flag -> Ast_414.Asttypes.private_flag = + function + | Ast_413.Asttypes.Private -> Ast_414.Asttypes.Private + | Ast_413.Asttypes.Public -> Ast_414.Asttypes.Public and copy_out_rec_status : Ast_413.Outcometree.out_rec_status -> Ast_414.Outcometree.out_rec_status = function @@ -194,6 +199,16 @@ and copy_out_type_param : fun x -> let (x0, x1) = x in (x0, (let (x0, x1) = x1 in ((copy_variance x0), (copy_injectivity x1)))) +and copy_injectivity : + Ast_413.Asttypes.injectivity -> Ast_414.Asttypes.injectivity = + function + | Ast_413.Asttypes.Injective -> Ast_414.Asttypes.Injective + | Ast_413.Asttypes.NoInjectivity -> Ast_414.Asttypes.NoInjectivity +and copy_variance : Ast_413.Asttypes.variance -> Ast_414.Asttypes.variance = + function + | Ast_413.Asttypes.Covariant -> Ast_414.Asttypes.Covariant + | Ast_413.Asttypes.Contravariant -> Ast_414.Asttypes.Contravariant + | Ast_413.Asttypes.NoVariance -> Ast_414.Asttypes.NoVariance and copy_out_type : Ast_413.Outcometree.out_type -> Ast_414.Outcometree.out_type = function @@ -244,7 +259,9 @@ and copy_out_type : ((List.map (fun x -> x) x0), (copy_out_type x1)) | Ast_413.Outcometree.Otyp_module (x0, x1) -> Ast_414.Outcometree.Otyp_module - ((copy_out_ident x0), (List.map (fun (x, y) -> x, copy_out_type y) x1)) + ((copy_out_ident x0), + (List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) + x1)) | Ast_413.Outcometree.Otyp_attribute (x0, x1) -> Ast_414.Outcometree.Otyp_attribute ((copy_out_type x0), (copy_out_attribute x1)) @@ -315,1221 +332,3 @@ and copy_out_name : Ast_413.Outcometree.out_name -> Ast_414.Outcometree.out_name = fun { Ast_413.Outcometree.printed_name = printed_name } -> { Ast_414.Outcometree.printed_name = printed_name } -and copy_toplevel_phrase : - Ast_413.Parsetree.toplevel_phrase -> Ast_414.Parsetree.toplevel_phrase = - function - | Ast_413.Parsetree.Ptop_def x0 -> - Ast_414.Parsetree.Ptop_def (copy_structure x0) - | Ast_413.Parsetree.Ptop_dir x0 -> - Ast_414.Parsetree.Ptop_dir (copy_toplevel_directive x0) -and copy_toplevel_directive : - Ast_413.Parsetree.toplevel_directive -> - Ast_414.Parsetree.toplevel_directive - = - fun - { Ast_413.Parsetree.pdir_name = pdir_name; - Ast_413.Parsetree.pdir_arg = pdir_arg; - Ast_413.Parsetree.pdir_loc = pdir_loc } - -> - { - Ast_414.Parsetree.pdir_name = (copy_loc (fun x -> x) pdir_name); - Ast_414.Parsetree.pdir_arg = - (Option.map copy_directive_argument pdir_arg); - Ast_414.Parsetree.pdir_loc = (copy_location pdir_loc) - } -and copy_directive_argument : - Ast_413.Parsetree.directive_argument -> - Ast_414.Parsetree.directive_argument - = - fun - { Ast_413.Parsetree.pdira_desc = pdira_desc; - Ast_413.Parsetree.pdira_loc = pdira_loc } - -> - { - Ast_414.Parsetree.pdira_desc = - (copy_directive_argument_desc pdira_desc); - Ast_414.Parsetree.pdira_loc = (copy_location pdira_loc) - } -and copy_directive_argument_desc : - Ast_413.Parsetree.directive_argument_desc -> - Ast_414.Parsetree.directive_argument_desc - = - function - | Ast_413.Parsetree.Pdir_string x0 -> Ast_414.Parsetree.Pdir_string x0 - | Ast_413.Parsetree.Pdir_int (x0, x1) -> - Ast_414.Parsetree.Pdir_int (x0, (Option.map (fun x -> x) x1)) - | Ast_413.Parsetree.Pdir_ident x0 -> - Ast_414.Parsetree.Pdir_ident (copy_Longident_t x0) - | Ast_413.Parsetree.Pdir_bool x0 -> Ast_414.Parsetree.Pdir_bool x0 -and copy_expression : - Ast_413.Parsetree.expression -> Ast_414.Parsetree.expression = - fun - { Ast_413.Parsetree.pexp_desc = pexp_desc; - Ast_413.Parsetree.pexp_loc = pexp_loc; - Ast_413.Parsetree.pexp_loc_stack = pexp_loc_stack; - Ast_413.Parsetree.pexp_attributes = pexp_attributes } - -> - { - Ast_414.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - Ast_414.Parsetree.pexp_loc = (copy_location pexp_loc); - Ast_414.Parsetree.pexp_loc_stack = (copy_location_stack pexp_loc_stack); - Ast_414.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } -and copy_expression_desc : - Ast_413.Parsetree.expression_desc -> Ast_414.Parsetree.expression_desc = - function - | Ast_413.Parsetree.Pexp_ident x0 -> - Ast_414.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) - | Ast_413.Parsetree.Pexp_constant x0 -> - Ast_414.Parsetree.Pexp_constant (copy_constant x0) - | Ast_413.Parsetree.Pexp_let (x0, x1, x2) -> - Ast_414.Parsetree.Pexp_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_expression x2)) - | Ast_413.Parsetree.Pexp_function x0 -> - Ast_414.Parsetree.Pexp_function (List.map copy_case x0) - | Ast_413.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_414.Parsetree.Pexp_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_expression x3)) - | Ast_413.Parsetree.Pexp_apply (x0, x1) -> - Ast_414.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_413.Parsetree.Pexp_match (x0, x1) -> - Ast_414.Parsetree.Pexp_match - ((copy_expression x0), (List.map copy_case x1)) - | Ast_413.Parsetree.Pexp_try (x0, x1) -> - Ast_414.Parsetree.Pexp_try - ((copy_expression x0), (List.map copy_case x1)) - | Ast_413.Parsetree.Pexp_tuple x0 -> - Ast_414.Parsetree.Pexp_tuple (List.map copy_expression x0) - | Ast_413.Parsetree.Pexp_construct (x0, x1) -> - Ast_414.Parsetree.Pexp_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_expression x1)) - | Ast_413.Parsetree.Pexp_variant (x0, x1) -> - Ast_414.Parsetree.Pexp_variant - ((copy_label x0), (Option.map copy_expression x1)) - | Ast_413.Parsetree.Pexp_record (x0, x1) -> - Ast_414.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_expression x1))) x0), - (Option.map copy_expression x1)) - | Ast_413.Parsetree.Pexp_field (x0, x1) -> - Ast_414.Parsetree.Pexp_field - ((copy_expression x0), (copy_loc copy_Longident_t x1)) - | Ast_413.Parsetree.Pexp_setfield (x0, x1, x2) -> - Ast_414.Parsetree.Pexp_setfield - ((copy_expression x0), (copy_loc copy_Longident_t x1), - (copy_expression x2)) - | Ast_413.Parsetree.Pexp_array x0 -> - Ast_414.Parsetree.Pexp_array (List.map copy_expression x0) - | Ast_413.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> - Ast_414.Parsetree.Pexp_ifthenelse - ((copy_expression x0), (copy_expression x1), - (Option.map copy_expression x2)) - | Ast_413.Parsetree.Pexp_sequence (x0, x1) -> - Ast_414.Parsetree.Pexp_sequence - ((copy_expression x0), (copy_expression x1)) - | Ast_413.Parsetree.Pexp_while (x0, x1) -> - Ast_414.Parsetree.Pexp_while - ((copy_expression x0), (copy_expression x1)) - | Ast_413.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> - Ast_414.Parsetree.Pexp_for - ((copy_pattern x0), (copy_expression x1), (copy_expression x2), - (copy_direction_flag x3), (copy_expression x4)) - | Ast_413.Parsetree.Pexp_constraint (x0, x1) -> - Ast_414.Parsetree.Pexp_constraint - ((copy_expression x0), (copy_core_type x1)) - | Ast_413.Parsetree.Pexp_coerce (x0, x1, x2) -> - Ast_414.Parsetree.Pexp_coerce - ((copy_expression x0), (Option.map copy_core_type x1), - (copy_core_type x2)) - | Ast_413.Parsetree.Pexp_send (x0, x1) -> - Ast_414.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc copy_label x1)) - | Ast_413.Parsetree.Pexp_new x0 -> - Ast_414.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) - | Ast_413.Parsetree.Pexp_setinstvar (x0, x1) -> - Ast_414.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), (copy_expression x1)) - | Ast_413.Parsetree.Pexp_override x0 -> - Ast_414.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_label x0), (copy_expression x1))) x0) - | Ast_413.Parsetree.Pexp_letmodule (x0, x1, x2) -> - Ast_414.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_expr x1), (copy_expression x2)) - | Ast_413.Parsetree.Pexp_letexception (x0, x1) -> - Ast_414.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), (copy_expression x1)) - | Ast_413.Parsetree.Pexp_assert x0 -> - Ast_414.Parsetree.Pexp_assert (copy_expression x0) - | Ast_413.Parsetree.Pexp_lazy x0 -> - Ast_414.Parsetree.Pexp_lazy (copy_expression x0) - | Ast_413.Parsetree.Pexp_poly (x0, x1) -> - Ast_414.Parsetree.Pexp_poly - ((copy_expression x0), (Option.map copy_core_type x1)) - | Ast_413.Parsetree.Pexp_object x0 -> - Ast_414.Parsetree.Pexp_object (copy_class_structure x0) - | Ast_413.Parsetree.Pexp_newtype (x0, x1) -> - Ast_414.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | Ast_413.Parsetree.Pexp_pack x0 -> - Ast_414.Parsetree.Pexp_pack (copy_module_expr x0) - | Ast_413.Parsetree.Pexp_open (x0, x1) -> - Ast_414.Parsetree.Pexp_open - ((copy_open_declaration x0), (copy_expression x1)) - | Ast_413.Parsetree.Pexp_letop x0 -> - Ast_414.Parsetree.Pexp_letop (copy_letop x0) - | Ast_413.Parsetree.Pexp_extension x0 -> - Ast_414.Parsetree.Pexp_extension (copy_extension x0) - | Ast_413.Parsetree.Pexp_unreachable -> Ast_414.Parsetree.Pexp_unreachable -and copy_letop : Ast_413.Parsetree.letop -> Ast_414.Parsetree.letop = - fun - { Ast_413.Parsetree.let_ = let_; Ast_413.Parsetree.ands = ands; - Ast_413.Parsetree.body = body } - -> - { - Ast_414.Parsetree.let_ = (copy_binding_op let_); - Ast_414.Parsetree.ands = (List.map copy_binding_op ands); - Ast_414.Parsetree.body = (copy_expression body) - } -and copy_binding_op : - Ast_413.Parsetree.binding_op -> Ast_414.Parsetree.binding_op = - fun - { Ast_413.Parsetree.pbop_op = pbop_op; - Ast_413.Parsetree.pbop_pat = pbop_pat; - Ast_413.Parsetree.pbop_exp = pbop_exp; - Ast_413.Parsetree.pbop_loc = pbop_loc } - -> - { - Ast_414.Parsetree.pbop_op = (copy_loc (fun x -> x) pbop_op); - Ast_414.Parsetree.pbop_pat = (copy_pattern pbop_pat); - Ast_414.Parsetree.pbop_exp = (copy_expression pbop_exp); - Ast_414.Parsetree.pbop_loc = (copy_location pbop_loc) - } -and copy_direction_flag : - Ast_413.Asttypes.direction_flag -> Ast_414.Asttypes.direction_flag = - function - | Ast_413.Asttypes.Upto -> Ast_414.Asttypes.Upto - | Ast_413.Asttypes.Downto -> Ast_414.Asttypes.Downto -and copy_case : Ast_413.Parsetree.case -> Ast_414.Parsetree.case = - fun - { Ast_413.Parsetree.pc_lhs = pc_lhs; - Ast_413.Parsetree.pc_guard = pc_guard; - Ast_413.Parsetree.pc_rhs = pc_rhs } - -> - { - Ast_414.Parsetree.pc_lhs = (copy_pattern pc_lhs); - Ast_414.Parsetree.pc_guard = (Option.map copy_expression pc_guard); - Ast_414.Parsetree.pc_rhs = (copy_expression pc_rhs) - } -and copy_value_binding : - Ast_413.Parsetree.value_binding -> Ast_414.Parsetree.value_binding = - fun - { Ast_413.Parsetree.pvb_pat = pvb_pat; - Ast_413.Parsetree.pvb_expr = pvb_expr; - Ast_413.Parsetree.pvb_attributes = pvb_attributes; - Ast_413.Parsetree.pvb_loc = pvb_loc } - -> - { - Ast_414.Parsetree.pvb_pat = (copy_pattern pvb_pat); - Ast_414.Parsetree.pvb_expr = (copy_expression pvb_expr); - Ast_414.Parsetree.pvb_attributes = (copy_attributes pvb_attributes); - Ast_414.Parsetree.pvb_loc = (copy_location pvb_loc) - } -and copy_pattern : Ast_413.Parsetree.pattern -> Ast_414.Parsetree.pattern = - fun - { Ast_413.Parsetree.ppat_desc = ppat_desc; - Ast_413.Parsetree.ppat_loc = ppat_loc; - Ast_413.Parsetree.ppat_loc_stack = ppat_loc_stack; - Ast_413.Parsetree.ppat_attributes = ppat_attributes } - -> - { - Ast_414.Parsetree.ppat_desc = (copy_pattern_desc ppat_desc); - Ast_414.Parsetree.ppat_loc = (copy_location ppat_loc); - Ast_414.Parsetree.ppat_loc_stack = (copy_location_stack ppat_loc_stack); - Ast_414.Parsetree.ppat_attributes = (copy_attributes ppat_attributes) - } -and copy_pattern_desc : - Ast_413.Parsetree.pattern_desc -> Ast_414.Parsetree.pattern_desc = - function - | Ast_413.Parsetree.Ppat_any -> Ast_414.Parsetree.Ppat_any - | Ast_413.Parsetree.Ppat_var x0 -> - Ast_414.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | Ast_413.Parsetree.Ppat_alias (x0, x1) -> - Ast_414.Parsetree.Ppat_alias - ((copy_pattern x0), (copy_loc (fun x -> x) x1)) - | Ast_413.Parsetree.Ppat_constant x0 -> - Ast_414.Parsetree.Ppat_constant (copy_constant x0) - | Ast_413.Parsetree.Ppat_interval (x0, x1) -> - Ast_414.Parsetree.Ppat_interval - ((copy_constant x0), (copy_constant x1)) - | Ast_413.Parsetree.Ppat_tuple x0 -> - Ast_414.Parsetree.Ppat_tuple (List.map copy_pattern x0) - | Ast_413.Parsetree.Ppat_construct (x0, x1) -> - Ast_414.Parsetree.Ppat_construct - ((copy_loc copy_Longident_t x0), (Option.map (fun (x0, x1) -> x0, copy_pattern x1) x1)) - | Ast_413.Parsetree.Ppat_variant (x0, x1) -> - Ast_414.Parsetree.Ppat_variant - ((copy_label x0), (Option.map copy_pattern x1)) - | Ast_413.Parsetree.Ppat_record (x0, x1) -> - Ast_414.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | Ast_413.Parsetree.Ppat_array x0 -> - Ast_414.Parsetree.Ppat_array (List.map copy_pattern x0) - | Ast_413.Parsetree.Ppat_or (x0, x1) -> - Ast_414.Parsetree.Ppat_or ((copy_pattern x0), (copy_pattern x1)) - | Ast_413.Parsetree.Ppat_constraint (x0, x1) -> - Ast_414.Parsetree.Ppat_constraint - ((copy_pattern x0), (copy_core_type x1)) - | Ast_413.Parsetree.Ppat_type x0 -> - Ast_414.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) - | Ast_413.Parsetree.Ppat_lazy x0 -> - Ast_414.Parsetree.Ppat_lazy (copy_pattern x0) - | Ast_413.Parsetree.Ppat_unpack x0 -> - Ast_414.Parsetree.Ppat_unpack - (copy_loc (fun x -> Option.map (fun x -> x) x) x0) - | Ast_413.Parsetree.Ppat_exception x0 -> - Ast_414.Parsetree.Ppat_exception (copy_pattern x0) - | Ast_413.Parsetree.Ppat_extension x0 -> - Ast_414.Parsetree.Ppat_extension (copy_extension x0) - | Ast_413.Parsetree.Ppat_open (x0, x1) -> - Ast_414.Parsetree.Ppat_open - ((copy_loc copy_Longident_t x0), (copy_pattern x1)) -and copy_core_type : - Ast_413.Parsetree.core_type -> Ast_414.Parsetree.core_type = - fun - { Ast_413.Parsetree.ptyp_desc = ptyp_desc; - Ast_413.Parsetree.ptyp_loc = ptyp_loc; - Ast_413.Parsetree.ptyp_loc_stack = ptyp_loc_stack; - Ast_413.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - Ast_414.Parsetree.ptyp_desc = (copy_core_type_desc ptyp_desc); - Ast_414.Parsetree.ptyp_loc = (copy_location ptyp_loc); - Ast_414.Parsetree.ptyp_loc_stack = (copy_location_stack ptyp_loc_stack); - Ast_414.Parsetree.ptyp_attributes = (copy_attributes ptyp_attributes) - } -and copy_location_stack : - Ast_413.Parsetree.location_stack -> Ast_414.Parsetree.location_stack = - fun x -> List.map copy_location x -and copy_core_type_desc : - Ast_413.Parsetree.core_type_desc -> Ast_414.Parsetree.core_type_desc = - function - | Ast_413.Parsetree.Ptyp_any -> Ast_414.Parsetree.Ptyp_any - | Ast_413.Parsetree.Ptyp_var x0 -> Ast_414.Parsetree.Ptyp_var x0 - | Ast_413.Parsetree.Ptyp_arrow (x0, x1, x2) -> - Ast_414.Parsetree.Ptyp_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_core_type x2)) - | Ast_413.Parsetree.Ptyp_tuple x0 -> - Ast_414.Parsetree.Ptyp_tuple (List.map copy_core_type x0) - | Ast_413.Parsetree.Ptyp_constr (x0, x1) -> - Ast_414.Parsetree.Ptyp_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_413.Parsetree.Ptyp_object (x0, x1) -> - Ast_414.Parsetree.Ptyp_object - ((List.map copy_object_field x0), (copy_closed_flag x1)) - | Ast_413.Parsetree.Ptyp_class (x0, x1) -> - Ast_414.Parsetree.Ptyp_class - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_413.Parsetree.Ptyp_alias (x0, x1) -> - Ast_414.Parsetree.Ptyp_alias ((copy_core_type x0), x1) - | Ast_413.Parsetree.Ptyp_variant (x0, x1, x2) -> - Ast_414.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), (copy_closed_flag x1), - (Option.map (fun x -> List.map copy_label x) x2)) - | Ast_413.Parsetree.Ptyp_poly (x0, x1) -> - Ast_414.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | Ast_413.Parsetree.Ptyp_package x0 -> - Ast_414.Parsetree.Ptyp_package (copy_package_type x0) - | Ast_413.Parsetree.Ptyp_extension x0 -> - Ast_414.Parsetree.Ptyp_extension (copy_extension x0) -and copy_package_type : - Ast_413.Parsetree.package_type -> Ast_414.Parsetree.package_type = - fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_core_type x1))) x1)) -and copy_row_field : - Ast_413.Parsetree.row_field -> Ast_414.Parsetree.row_field = - fun - { Ast_413.Parsetree.prf_desc = prf_desc; - Ast_413.Parsetree.prf_loc = prf_loc; - Ast_413.Parsetree.prf_attributes = prf_attributes } - -> - { - Ast_414.Parsetree.prf_desc = (copy_row_field_desc prf_desc); - Ast_414.Parsetree.prf_loc = (copy_location prf_loc); - Ast_414.Parsetree.prf_attributes = (copy_attributes prf_attributes) - } -and copy_row_field_desc : - Ast_413.Parsetree.row_field_desc -> Ast_414.Parsetree.row_field_desc = - function - | Ast_413.Parsetree.Rtag (x0, x1, x2) -> - Ast_414.Parsetree.Rtag - ((copy_loc copy_label x0), x1, (List.map copy_core_type x2)) - | Ast_413.Parsetree.Rinherit x0 -> - Ast_414.Parsetree.Rinherit (copy_core_type x0) -and copy_object_field : - Ast_413.Parsetree.object_field -> Ast_414.Parsetree.object_field = - fun - { Ast_413.Parsetree.pof_desc = pof_desc; - Ast_413.Parsetree.pof_loc = pof_loc; - Ast_413.Parsetree.pof_attributes = pof_attributes } - -> - { - Ast_414.Parsetree.pof_desc = (copy_object_field_desc pof_desc); - Ast_414.Parsetree.pof_loc = (copy_location pof_loc); - Ast_414.Parsetree.pof_attributes = (copy_attributes pof_attributes) - } -and copy_attributes : - Ast_413.Parsetree.attributes -> Ast_414.Parsetree.attributes = - fun x -> List.map copy_attribute x -and copy_attribute : - Ast_413.Parsetree.attribute -> Ast_414.Parsetree.attribute = - fun - { Ast_413.Parsetree.attr_name = attr_name; - Ast_413.Parsetree.attr_payload = attr_payload; - Ast_413.Parsetree.attr_loc = attr_loc } - -> - { - Ast_414.Parsetree.attr_name = (copy_loc (fun x -> x) attr_name); - Ast_414.Parsetree.attr_payload = (copy_payload attr_payload); - Ast_414.Parsetree.attr_loc = (copy_location attr_loc) - } -and copy_payload : Ast_413.Parsetree.payload -> Ast_414.Parsetree.payload = - function - | Ast_413.Parsetree.PStr x0 -> Ast_414.Parsetree.PStr (copy_structure x0) - | Ast_413.Parsetree.PSig x0 -> Ast_414.Parsetree.PSig (copy_signature x0) - | Ast_413.Parsetree.PTyp x0 -> Ast_414.Parsetree.PTyp (copy_core_type x0) - | Ast_413.Parsetree.PPat (x0, x1) -> - Ast_414.Parsetree.PPat - ((copy_pattern x0), (Option.map copy_expression x1)) -and copy_structure : - Ast_413.Parsetree.structure -> Ast_414.Parsetree.structure = - fun x -> List.map copy_structure_item x -and copy_structure_item : - Ast_413.Parsetree.structure_item -> Ast_414.Parsetree.structure_item = - fun - { Ast_413.Parsetree.pstr_desc = pstr_desc; - Ast_413.Parsetree.pstr_loc = pstr_loc } - -> - { - Ast_414.Parsetree.pstr_desc = (copy_structure_item_desc pstr_desc); - Ast_414.Parsetree.pstr_loc = (copy_location pstr_loc) - } -and copy_structure_item_desc : - Ast_413.Parsetree.structure_item_desc -> - Ast_414.Parsetree.structure_item_desc - = - function - | Ast_413.Parsetree.Pstr_eval (x0, x1) -> - Ast_414.Parsetree.Pstr_eval - ((copy_expression x0), (copy_attributes x1)) - | Ast_413.Parsetree.Pstr_value (x0, x1) -> - Ast_414.Parsetree.Pstr_value - ((copy_rec_flag x0), (List.map copy_value_binding x1)) - | Ast_413.Parsetree.Pstr_primitive x0 -> - Ast_414.Parsetree.Pstr_primitive (copy_value_description x0) - | Ast_413.Parsetree.Pstr_type (x0, x1) -> - Ast_414.Parsetree.Pstr_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_413.Parsetree.Pstr_typext x0 -> - Ast_414.Parsetree.Pstr_typext (copy_type_extension x0) - | Ast_413.Parsetree.Pstr_exception x0 -> - Ast_414.Parsetree.Pstr_exception (copy_type_exception x0) - | Ast_413.Parsetree.Pstr_module x0 -> - Ast_414.Parsetree.Pstr_module (copy_module_binding x0) - | Ast_413.Parsetree.Pstr_recmodule x0 -> - Ast_414.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) - | Ast_413.Parsetree.Pstr_modtype x0 -> - Ast_414.Parsetree.Pstr_modtype (copy_module_type_declaration x0) - | Ast_413.Parsetree.Pstr_open x0 -> - Ast_414.Parsetree.Pstr_open (copy_open_declaration x0) - | Ast_413.Parsetree.Pstr_class x0 -> - Ast_414.Parsetree.Pstr_class (List.map copy_class_declaration x0) - | Ast_413.Parsetree.Pstr_class_type x0 -> - Ast_414.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | Ast_413.Parsetree.Pstr_include x0 -> - Ast_414.Parsetree.Pstr_include (copy_include_declaration x0) - | Ast_413.Parsetree.Pstr_attribute x0 -> - Ast_414.Parsetree.Pstr_attribute (copy_attribute x0) - | Ast_413.Parsetree.Pstr_extension (x0, x1) -> - Ast_414.Parsetree.Pstr_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_include_declaration : - Ast_413.Parsetree.include_declaration -> - Ast_414.Parsetree.include_declaration - = fun x -> copy_include_infos copy_module_expr x -and copy_class_declaration : - Ast_413.Parsetree.class_declaration -> Ast_414.Parsetree.class_declaration - = fun x -> copy_class_infos copy_class_expr x -and copy_class_expr : - Ast_413.Parsetree.class_expr -> Ast_414.Parsetree.class_expr = - fun - { Ast_413.Parsetree.pcl_desc = pcl_desc; - Ast_413.Parsetree.pcl_loc = pcl_loc; - Ast_413.Parsetree.pcl_attributes = pcl_attributes } - -> - { - Ast_414.Parsetree.pcl_desc = (copy_class_expr_desc pcl_desc); - Ast_414.Parsetree.pcl_loc = (copy_location pcl_loc); - Ast_414.Parsetree.pcl_attributes = (copy_attributes pcl_attributes) - } -and copy_class_expr_desc : - Ast_413.Parsetree.class_expr_desc -> Ast_414.Parsetree.class_expr_desc = - function - | Ast_413.Parsetree.Pcl_constr (x0, x1) -> - Ast_414.Parsetree.Pcl_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_413.Parsetree.Pcl_structure x0 -> - Ast_414.Parsetree.Pcl_structure (copy_class_structure x0) - | Ast_413.Parsetree.Pcl_fun (x0, x1, x2, x3) -> - Ast_414.Parsetree.Pcl_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_class_expr x3)) - | Ast_413.Parsetree.Pcl_apply (x0, x1) -> - Ast_414.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_413.Parsetree.Pcl_let (x0, x1, x2) -> - Ast_414.Parsetree.Pcl_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_class_expr x2)) - | Ast_413.Parsetree.Pcl_constraint (x0, x1) -> - Ast_414.Parsetree.Pcl_constraint - ((copy_class_expr x0), (copy_class_type x1)) - | Ast_413.Parsetree.Pcl_extension x0 -> - Ast_414.Parsetree.Pcl_extension (copy_extension x0) - | Ast_413.Parsetree.Pcl_open (x0, x1) -> - Ast_414.Parsetree.Pcl_open - ((copy_open_description x0), (copy_class_expr x1)) -and copy_class_structure : - Ast_413.Parsetree.class_structure -> Ast_414.Parsetree.class_structure = - fun - { Ast_413.Parsetree.pcstr_self = pcstr_self; - Ast_413.Parsetree.pcstr_fields = pcstr_fields } - -> - { - Ast_414.Parsetree.pcstr_self = (copy_pattern pcstr_self); - Ast_414.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } -and copy_class_field : - Ast_413.Parsetree.class_field -> Ast_414.Parsetree.class_field = - fun - { Ast_413.Parsetree.pcf_desc = pcf_desc; - Ast_413.Parsetree.pcf_loc = pcf_loc; - Ast_413.Parsetree.pcf_attributes = pcf_attributes } - -> - { - Ast_414.Parsetree.pcf_desc = (copy_class_field_desc pcf_desc); - Ast_414.Parsetree.pcf_loc = (copy_location pcf_loc); - Ast_414.Parsetree.pcf_attributes = (copy_attributes pcf_attributes) - } -and copy_class_field_desc : - Ast_413.Parsetree.class_field_desc -> Ast_414.Parsetree.class_field_desc = - function - | Ast_413.Parsetree.Pcf_inherit (x0, x1, x2) -> - Ast_414.Parsetree.Pcf_inherit - ((copy_override_flag x0), (copy_class_expr x1), - (Option.map (fun x -> copy_loc (fun x -> x) x) x2)) - | Ast_413.Parsetree.Pcf_val x0 -> - Ast_414.Parsetree.Pcf_val - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | Ast_413.Parsetree.Pcf_method x0 -> - Ast_414.Parsetree.Pcf_method - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_class_field_kind x2))) - | Ast_413.Parsetree.Pcf_constraint x0 -> - Ast_414.Parsetree.Pcf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_413.Parsetree.Pcf_initializer x0 -> - Ast_414.Parsetree.Pcf_initializer (copy_expression x0) - | Ast_413.Parsetree.Pcf_attribute x0 -> - Ast_414.Parsetree.Pcf_attribute (copy_attribute x0) - | Ast_413.Parsetree.Pcf_extension x0 -> - Ast_414.Parsetree.Pcf_extension (copy_extension x0) -and copy_class_field_kind : - Ast_413.Parsetree.class_field_kind -> Ast_414.Parsetree.class_field_kind = - function - | Ast_413.Parsetree.Cfk_virtual x0 -> - Ast_414.Parsetree.Cfk_virtual (copy_core_type x0) - | Ast_413.Parsetree.Cfk_concrete (x0, x1) -> - Ast_414.Parsetree.Cfk_concrete - ((copy_override_flag x0), (copy_expression x1)) -and copy_open_declaration : - Ast_413.Parsetree.open_declaration -> Ast_414.Parsetree.open_declaration = - fun x -> copy_open_infos copy_module_expr x -and copy_module_binding : - Ast_413.Parsetree.module_binding -> Ast_414.Parsetree.module_binding = - fun - { Ast_413.Parsetree.pmb_name = pmb_name; - Ast_413.Parsetree.pmb_expr = pmb_expr; - Ast_413.Parsetree.pmb_attributes = pmb_attributes; - Ast_413.Parsetree.pmb_loc = pmb_loc } - -> - { - Ast_414.Parsetree.pmb_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name); - Ast_414.Parsetree.pmb_expr = (copy_module_expr pmb_expr); - Ast_414.Parsetree.pmb_attributes = (copy_attributes pmb_attributes); - Ast_414.Parsetree.pmb_loc = (copy_location pmb_loc) - } -and copy_module_expr : - Ast_413.Parsetree.module_expr -> Ast_414.Parsetree.module_expr = - fun - { Ast_413.Parsetree.pmod_desc = pmod_desc; - Ast_413.Parsetree.pmod_loc = pmod_loc; - Ast_413.Parsetree.pmod_attributes = pmod_attributes } - -> - { - Ast_414.Parsetree.pmod_desc = (copy_module_expr_desc pmod_desc); - Ast_414.Parsetree.pmod_loc = (copy_location pmod_loc); - Ast_414.Parsetree.pmod_attributes = (copy_attributes pmod_attributes) - } -and copy_module_expr_desc : - Ast_413.Parsetree.module_expr_desc -> Ast_414.Parsetree.module_expr_desc = - function - | Ast_413.Parsetree.Pmod_ident x0 -> - Ast_414.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) - | Ast_413.Parsetree.Pmod_structure x0 -> - Ast_414.Parsetree.Pmod_structure (copy_structure x0) - | Ast_413.Parsetree.Pmod_functor (x0, x1) -> - Ast_414.Parsetree.Pmod_functor - ((copy_functor_parameter x0), (copy_module_expr x1)) - | Ast_413.Parsetree.Pmod_apply (x0, x1) -> - Ast_414.Parsetree.Pmod_apply - ((copy_module_expr x0), (copy_module_expr x1)) - | Ast_413.Parsetree.Pmod_constraint (x0, x1) -> - Ast_414.Parsetree.Pmod_constraint - ((copy_module_expr x0), (copy_module_type x1)) - | Ast_413.Parsetree.Pmod_unpack x0 -> - Ast_414.Parsetree.Pmod_unpack (copy_expression x0) - | Ast_413.Parsetree.Pmod_extension x0 -> - Ast_414.Parsetree.Pmod_extension (copy_extension x0) -and copy_functor_parameter : - Ast_413.Parsetree.functor_parameter -> Ast_414.Parsetree.functor_parameter - = - function - | Ast_413.Parsetree.Unit -> Ast_414.Parsetree.Unit - | Ast_413.Parsetree.Named (x0, x1) -> - Ast_414.Parsetree.Named - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_type x1)) -and copy_module_type : - Ast_413.Parsetree.module_type -> Ast_414.Parsetree.module_type = - fun - { Ast_413.Parsetree.pmty_desc = pmty_desc; - Ast_413.Parsetree.pmty_loc = pmty_loc; - Ast_413.Parsetree.pmty_attributes = pmty_attributes } - -> - { - Ast_414.Parsetree.pmty_desc = (copy_module_type_desc pmty_desc); - Ast_414.Parsetree.pmty_loc = (copy_location pmty_loc); - Ast_414.Parsetree.pmty_attributes = (copy_attributes pmty_attributes) - } -and copy_module_type_desc : - Ast_413.Parsetree.module_type_desc -> Ast_414.Parsetree.module_type_desc = - function - | Ast_413.Parsetree.Pmty_ident x0 -> - Ast_414.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) - | Ast_413.Parsetree.Pmty_signature x0 -> - Ast_414.Parsetree.Pmty_signature (copy_signature x0) - | Ast_413.Parsetree.Pmty_functor (x0, x1) -> - Ast_414.Parsetree.Pmty_functor - ((copy_functor_parameter x0), (copy_module_type x1)) - | Ast_413.Parsetree.Pmty_with (x0, x1) -> - Ast_414.Parsetree.Pmty_with - ((copy_module_type x0), (List.map copy_with_constraint x1)) - | Ast_413.Parsetree.Pmty_typeof x0 -> - Ast_414.Parsetree.Pmty_typeof (copy_module_expr x0) - | Ast_413.Parsetree.Pmty_extension x0 -> - Ast_414.Parsetree.Pmty_extension (copy_extension x0) - | Ast_413.Parsetree.Pmty_alias x0 -> - Ast_414.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) -and copy_with_constraint : - Ast_413.Parsetree.with_constraint -> Ast_414.Parsetree.with_constraint = - function - | Ast_413.Parsetree.Pwith_type (x0, x1) -> - Ast_414.Parsetree.Pwith_type - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_413.Parsetree.Pwith_module (x0, x1) -> - Ast_414.Parsetree.Pwith_module - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) - | Ast_413.Parsetree.Pwith_modtype (x0, x1) -> - Ast_414.Parsetree.Pwith_modtype - ((copy_loc copy_Longident_t x0), (copy_module_type x1)) - | Ast_413.Parsetree.Pwith_modtypesubst (x0, x1) -> - Ast_414.Parsetree.Pwith_modtypesubst - ((copy_loc copy_Longident_t x0), (copy_module_type x1)) - | Ast_413.Parsetree.Pwith_typesubst (x0, x1) -> - Ast_414.Parsetree.Pwith_typesubst - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_413.Parsetree.Pwith_modsubst (x0, x1) -> - Ast_414.Parsetree.Pwith_modsubst - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) -and copy_signature : - Ast_413.Parsetree.signature -> Ast_414.Parsetree.signature = - fun x -> List.map copy_signature_item x -and copy_signature_item : - Ast_413.Parsetree.signature_item -> Ast_414.Parsetree.signature_item = - fun - { Ast_413.Parsetree.psig_desc = psig_desc; - Ast_413.Parsetree.psig_loc = psig_loc } - -> - { - Ast_414.Parsetree.psig_desc = (copy_signature_item_desc psig_desc); - Ast_414.Parsetree.psig_loc = (copy_location psig_loc) - } -and copy_signature_item_desc : - Ast_413.Parsetree.signature_item_desc -> - Ast_414.Parsetree.signature_item_desc - = - function - | Ast_413.Parsetree.Psig_value x0 -> - Ast_414.Parsetree.Psig_value (copy_value_description x0) - | Ast_413.Parsetree.Psig_type (x0, x1) -> - Ast_414.Parsetree.Psig_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_413.Parsetree.Psig_typesubst x0 -> - Ast_414.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) - | Ast_413.Parsetree.Psig_typext x0 -> - Ast_414.Parsetree.Psig_typext (copy_type_extension x0) - | Ast_413.Parsetree.Psig_exception x0 -> - Ast_414.Parsetree.Psig_exception (copy_type_exception x0) - | Ast_413.Parsetree.Psig_module x0 -> - Ast_414.Parsetree.Psig_module (copy_module_declaration x0) - | Ast_413.Parsetree.Psig_modsubst x0 -> - Ast_414.Parsetree.Psig_modsubst (copy_module_substitution x0) - | Ast_413.Parsetree.Psig_recmodule x0 -> - Ast_414.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) - | Ast_413.Parsetree.Psig_modtype x0 -> - Ast_414.Parsetree.Psig_modtype (copy_module_type_declaration x0) - | Ast_413.Parsetree.Psig_modtypesubst x0 -> - Ast_414.Parsetree.Psig_modtypesubst (copy_module_type_declaration x0) - | Ast_413.Parsetree.Psig_open x0 -> - Ast_414.Parsetree.Psig_open (copy_open_description x0) - | Ast_413.Parsetree.Psig_include x0 -> - Ast_414.Parsetree.Psig_include (copy_include_description x0) - | Ast_413.Parsetree.Psig_class x0 -> - Ast_414.Parsetree.Psig_class (List.map copy_class_description x0) - | Ast_413.Parsetree.Psig_class_type x0 -> - Ast_414.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | Ast_413.Parsetree.Psig_attribute x0 -> - Ast_414.Parsetree.Psig_attribute (copy_attribute x0) - | Ast_413.Parsetree.Psig_extension (x0, x1) -> - Ast_414.Parsetree.Psig_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_class_type_declaration : - Ast_413.Parsetree.class_type_declaration -> - Ast_414.Parsetree.class_type_declaration - = fun x -> copy_class_infos copy_class_type x -and copy_class_description : - Ast_413.Parsetree.class_description -> Ast_414.Parsetree.class_description - = fun x -> copy_class_infos copy_class_type x -and copy_class_type : - Ast_413.Parsetree.class_type -> Ast_414.Parsetree.class_type = - fun - { Ast_413.Parsetree.pcty_desc = pcty_desc; - Ast_413.Parsetree.pcty_loc = pcty_loc; - Ast_413.Parsetree.pcty_attributes = pcty_attributes } - -> - { - Ast_414.Parsetree.pcty_desc = (copy_class_type_desc pcty_desc); - Ast_414.Parsetree.pcty_loc = (copy_location pcty_loc); - Ast_414.Parsetree.pcty_attributes = (copy_attributes pcty_attributes) - } -and copy_class_type_desc : - Ast_413.Parsetree.class_type_desc -> Ast_414.Parsetree.class_type_desc = - function - | Ast_413.Parsetree.Pcty_constr (x0, x1) -> - Ast_414.Parsetree.Pcty_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_413.Parsetree.Pcty_signature x0 -> - Ast_414.Parsetree.Pcty_signature (copy_class_signature x0) - | Ast_413.Parsetree.Pcty_arrow (x0, x1, x2) -> - Ast_414.Parsetree.Pcty_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_class_type x2)) - | Ast_413.Parsetree.Pcty_extension x0 -> - Ast_414.Parsetree.Pcty_extension (copy_extension x0) - | Ast_413.Parsetree.Pcty_open (x0, x1) -> - Ast_414.Parsetree.Pcty_open - ((copy_open_description x0), (copy_class_type x1)) -and copy_class_signature : - Ast_413.Parsetree.class_signature -> Ast_414.Parsetree.class_signature = - fun - { Ast_413.Parsetree.pcsig_self = pcsig_self; - Ast_413.Parsetree.pcsig_fields = pcsig_fields } - -> - { - Ast_414.Parsetree.pcsig_self = (copy_core_type pcsig_self); - Ast_414.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } -and copy_class_type_field : - Ast_413.Parsetree.class_type_field -> Ast_414.Parsetree.class_type_field = - fun - { Ast_413.Parsetree.pctf_desc = pctf_desc; - Ast_413.Parsetree.pctf_loc = pctf_loc; - Ast_413.Parsetree.pctf_attributes = pctf_attributes } - -> - { - Ast_414.Parsetree.pctf_desc = (copy_class_type_field_desc pctf_desc); - Ast_414.Parsetree.pctf_loc = (copy_location pctf_loc); - Ast_414.Parsetree.pctf_attributes = (copy_attributes pctf_attributes) - } -and copy_class_type_field_desc : - Ast_413.Parsetree.class_type_field_desc -> - Ast_414.Parsetree.class_type_field_desc - = - function - | Ast_413.Parsetree.Pctf_inherit x0 -> - Ast_414.Parsetree.Pctf_inherit (copy_class_type x0) - | Ast_413.Parsetree.Pctf_val x0 -> - Ast_414.Parsetree.Pctf_val - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_413.Parsetree.Pctf_method x0 -> - Ast_414.Parsetree.Pctf_method - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_413.Parsetree.Pctf_constraint x0 -> - Ast_414.Parsetree.Pctf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_413.Parsetree.Pctf_attribute x0 -> - Ast_414.Parsetree.Pctf_attribute (copy_attribute x0) - | Ast_413.Parsetree.Pctf_extension x0 -> - Ast_414.Parsetree.Pctf_extension (copy_extension x0) -and copy_extension : - Ast_413.Parsetree.extension -> Ast_414.Parsetree.extension = - fun x -> - let (x0, x1) = x in ((copy_loc (fun x -> x) x0), (copy_payload x1)) -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_413.Parsetree.class_infos -> 'g0 Ast_414.Parsetree.class_infos - = - fun f0 -> - fun - { Ast_413.Parsetree.pci_virt = pci_virt; - Ast_413.Parsetree.pci_params = pci_params; - Ast_413.Parsetree.pci_name = pci_name; - Ast_413.Parsetree.pci_expr = pci_expr; - Ast_413.Parsetree.pci_loc = pci_loc; - Ast_413.Parsetree.pci_attributes = pci_attributes } - -> - { - Ast_414.Parsetree.pci_virt = (copy_virtual_flag pci_virt); - Ast_414.Parsetree.pci_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) pci_params); - Ast_414.Parsetree.pci_name = (copy_loc (fun x -> x) pci_name); - Ast_414.Parsetree.pci_expr = (f0 pci_expr); - Ast_414.Parsetree.pci_loc = (copy_location pci_loc); - Ast_414.Parsetree.pci_attributes = (copy_attributes pci_attributes) - } -and copy_virtual_flag : - Ast_413.Asttypes.virtual_flag -> Ast_414.Asttypes.virtual_flag = - function - | Ast_413.Asttypes.Virtual -> Ast_414.Asttypes.Virtual - | Ast_413.Asttypes.Concrete -> Ast_414.Asttypes.Concrete -and copy_include_description : - Ast_413.Parsetree.include_description -> - Ast_414.Parsetree.include_description - = fun x -> copy_include_infos copy_module_type x -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_413.Parsetree.include_infos -> - 'g0 Ast_414.Parsetree.include_infos - = - fun f0 -> - fun - { Ast_413.Parsetree.pincl_mod = pincl_mod; - Ast_413.Parsetree.pincl_loc = pincl_loc; - Ast_413.Parsetree.pincl_attributes = pincl_attributes } - -> - { - Ast_414.Parsetree.pincl_mod = (f0 pincl_mod); - Ast_414.Parsetree.pincl_loc = (copy_location pincl_loc); - Ast_414.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } -and copy_open_description : - Ast_413.Parsetree.open_description -> Ast_414.Parsetree.open_description = - fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x -and copy_open_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_413.Parsetree.open_infos -> 'g0 Ast_414.Parsetree.open_infos - = - fun f0 -> - fun - { Ast_413.Parsetree.popen_expr = popen_expr; - Ast_413.Parsetree.popen_override = popen_override; - Ast_413.Parsetree.popen_loc = popen_loc; - Ast_413.Parsetree.popen_attributes = popen_attributes } - -> - { - Ast_414.Parsetree.popen_expr = (f0 popen_expr); - Ast_414.Parsetree.popen_override = - (copy_override_flag popen_override); - Ast_414.Parsetree.popen_loc = (copy_location popen_loc); - Ast_414.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } -and copy_override_flag : - Ast_413.Asttypes.override_flag -> Ast_414.Asttypes.override_flag = - function - | Ast_413.Asttypes.Override -> Ast_414.Asttypes.Override - | Ast_413.Asttypes.Fresh -> Ast_414.Asttypes.Fresh -and copy_module_type_declaration : - Ast_413.Parsetree.module_type_declaration -> - Ast_414.Parsetree.module_type_declaration - = - fun - { Ast_413.Parsetree.pmtd_name = pmtd_name; - Ast_413.Parsetree.pmtd_type = pmtd_type; - Ast_413.Parsetree.pmtd_attributes = pmtd_attributes; - Ast_413.Parsetree.pmtd_loc = pmtd_loc } - -> - { - Ast_414.Parsetree.pmtd_name = (copy_loc (fun x -> x) pmtd_name); - Ast_414.Parsetree.pmtd_type = (Option.map copy_module_type pmtd_type); - Ast_414.Parsetree.pmtd_attributes = (copy_attributes pmtd_attributes); - Ast_414.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } -and copy_module_substitution : - Ast_413.Parsetree.module_substitution -> - Ast_414.Parsetree.module_substitution - = - fun - { Ast_413.Parsetree.pms_name = pms_name; - Ast_413.Parsetree.pms_manifest = pms_manifest; - Ast_413.Parsetree.pms_attributes = pms_attributes; - Ast_413.Parsetree.pms_loc = pms_loc } - -> - { - Ast_414.Parsetree.pms_name = (copy_loc (fun x -> x) pms_name); - Ast_414.Parsetree.pms_manifest = - (copy_loc copy_Longident_t pms_manifest); - Ast_414.Parsetree.pms_attributes = (copy_attributes pms_attributes); - Ast_414.Parsetree.pms_loc = (copy_location pms_loc) - } -and copy_module_declaration : - Ast_413.Parsetree.module_declaration -> - Ast_414.Parsetree.module_declaration - = - fun - { Ast_413.Parsetree.pmd_name = pmd_name; - Ast_413.Parsetree.pmd_type = pmd_type; - Ast_413.Parsetree.pmd_attributes = pmd_attributes; - Ast_413.Parsetree.pmd_loc = pmd_loc } - -> - { - Ast_414.Parsetree.pmd_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name); - Ast_414.Parsetree.pmd_type = (copy_module_type pmd_type); - Ast_414.Parsetree.pmd_attributes = (copy_attributes pmd_attributes); - Ast_414.Parsetree.pmd_loc = (copy_location pmd_loc) - } -and copy_type_exception : - Ast_413.Parsetree.type_exception -> Ast_414.Parsetree.type_exception = - fun - { Ast_413.Parsetree.ptyexn_constructor = ptyexn_constructor; - Ast_413.Parsetree.ptyexn_loc = ptyexn_loc; - Ast_413.Parsetree.ptyexn_attributes = ptyexn_attributes } - -> - { - Ast_414.Parsetree.ptyexn_constructor = - (copy_extension_constructor ptyexn_constructor); - Ast_414.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); - Ast_414.Parsetree.ptyexn_attributes = - (copy_attributes ptyexn_attributes) - } -and copy_type_extension : - Ast_413.Parsetree.type_extension -> Ast_414.Parsetree.type_extension = - fun - { Ast_413.Parsetree.ptyext_path = ptyext_path; - Ast_413.Parsetree.ptyext_params = ptyext_params; - Ast_413.Parsetree.ptyext_constructors = ptyext_constructors; - Ast_413.Parsetree.ptyext_private = ptyext_private; - Ast_413.Parsetree.ptyext_loc = ptyext_loc; - Ast_413.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - Ast_414.Parsetree.ptyext_path = (copy_loc copy_Longident_t ptyext_path); - Ast_414.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) ptyext_params); - Ast_414.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor ptyext_constructors); - Ast_414.Parsetree.ptyext_private = (copy_private_flag ptyext_private); - Ast_414.Parsetree.ptyext_loc = (copy_location ptyext_loc); - Ast_414.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } -and copy_extension_constructor : - Ast_413.Parsetree.extension_constructor -> - Ast_414.Parsetree.extension_constructor - = - fun - { Ast_413.Parsetree.pext_name = pext_name; - Ast_413.Parsetree.pext_kind = pext_kind; - Ast_413.Parsetree.pext_loc = pext_loc; - Ast_413.Parsetree.pext_attributes = pext_attributes } - -> - { - Ast_414.Parsetree.pext_name = (copy_loc (fun x -> x) pext_name); - Ast_414.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - Ast_414.Parsetree.pext_loc = (copy_location pext_loc); - Ast_414.Parsetree.pext_attributes = (copy_attributes pext_attributes) - } -and copy_extension_constructor_kind : - Ast_413.Parsetree.extension_constructor_kind -> - Ast_414.Parsetree.extension_constructor_kind - = - function - | Ast_413.Parsetree.Pext_decl (x0, x1) -> - Ast_414.Parsetree.Pext_decl - ([], (copy_constructor_arguments x0), (Option.map copy_core_type x1)) - | Ast_413.Parsetree.Pext_rebind x0 -> - Ast_414.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) -and copy_type_declaration : - Ast_413.Parsetree.type_declaration -> Ast_414.Parsetree.type_declaration = - fun - { Ast_413.Parsetree.ptype_name = ptype_name; - Ast_413.Parsetree.ptype_params = ptype_params; - Ast_413.Parsetree.ptype_cstrs = ptype_cstrs; - Ast_413.Parsetree.ptype_kind = ptype_kind; - Ast_413.Parsetree.ptype_private = ptype_private; - Ast_413.Parsetree.ptype_manifest = ptype_manifest; - Ast_413.Parsetree.ptype_attributes = ptype_attributes; - Ast_413.Parsetree.ptype_loc = ptype_loc } - -> - { - Ast_414.Parsetree.ptype_name = (copy_loc (fun x -> x) ptype_name); - Ast_414.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) ptype_params); - Ast_414.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0, x1, x2) = x in - ((copy_core_type x0), (copy_core_type x1), (copy_location x2))) - ptype_cstrs); - Ast_414.Parsetree.ptype_kind = (copy_type_kind ptype_kind); - Ast_414.Parsetree.ptype_private = (copy_private_flag ptype_private); - Ast_414.Parsetree.ptype_manifest = - (Option.map copy_core_type ptype_manifest); - Ast_414.Parsetree.ptype_attributes = (copy_attributes ptype_attributes); - Ast_414.Parsetree.ptype_loc = (copy_location ptype_loc) - } -and copy_private_flag : - Ast_413.Asttypes.private_flag -> Ast_414.Asttypes.private_flag = - function - | Ast_413.Asttypes.Private -> Ast_414.Asttypes.Private - | Ast_413.Asttypes.Public -> Ast_414.Asttypes.Public -and copy_type_kind : - Ast_413.Parsetree.type_kind -> Ast_414.Parsetree.type_kind = - function - | Ast_413.Parsetree.Ptype_abstract -> Ast_414.Parsetree.Ptype_abstract - | Ast_413.Parsetree.Ptype_variant x0 -> - Ast_414.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | Ast_413.Parsetree.Ptype_record x0 -> - Ast_414.Parsetree.Ptype_record (List.map copy_label_declaration x0) - | Ast_413.Parsetree.Ptype_open -> Ast_414.Parsetree.Ptype_open -and copy_constructor_declaration : - Ast_413.Parsetree.constructor_declaration -> - Ast_414.Parsetree.constructor_declaration - = - fun - { Ast_413.Parsetree.pcd_name = pcd_name; - Ast_413.Parsetree.pcd_args = pcd_args; - Ast_413.Parsetree.pcd_res = pcd_res; - Ast_413.Parsetree.pcd_loc = pcd_loc; - Ast_413.Parsetree.pcd_attributes = pcd_attributes } - -> - { - Ast_414.Parsetree.pcd_name = (copy_loc (fun x -> x) pcd_name); - Ast_414.Parsetree.pcd_vars = []; - Ast_414.Parsetree.pcd_args = (copy_constructor_arguments pcd_args); - Ast_414.Parsetree.pcd_res = (Option.map copy_core_type pcd_res); - Ast_414.Parsetree.pcd_loc = (copy_location pcd_loc); - Ast_414.Parsetree.pcd_attributes = (copy_attributes pcd_attributes) - } -and copy_constructor_arguments : - Ast_413.Parsetree.constructor_arguments -> - Ast_414.Parsetree.constructor_arguments - = - function - | Ast_413.Parsetree.Pcstr_tuple x0 -> - Ast_414.Parsetree.Pcstr_tuple (List.map copy_core_type x0) - | Ast_413.Parsetree.Pcstr_record x0 -> - Ast_414.Parsetree.Pcstr_record (List.map copy_label_declaration x0) -and copy_label_declaration : - Ast_413.Parsetree.label_declaration -> Ast_414.Parsetree.label_declaration - = - fun - { Ast_413.Parsetree.pld_name = pld_name; - Ast_413.Parsetree.pld_mutable = pld_mutable; - Ast_413.Parsetree.pld_type = pld_type; - Ast_413.Parsetree.pld_loc = pld_loc; - Ast_413.Parsetree.pld_attributes = pld_attributes } - -> - { - Ast_414.Parsetree.pld_name = (copy_loc (fun x -> x) pld_name); - Ast_414.Parsetree.pld_mutable = (copy_mutable_flag pld_mutable); - Ast_414.Parsetree.pld_type = (copy_core_type pld_type); - Ast_414.Parsetree.pld_loc = (copy_location pld_loc); - Ast_414.Parsetree.pld_attributes = (copy_attributes pld_attributes) - } -and copy_mutable_flag : - Ast_413.Asttypes.mutable_flag -> Ast_414.Asttypes.mutable_flag = - function - | Ast_413.Asttypes.Immutable -> Ast_414.Asttypes.Immutable - | Ast_413.Asttypes.Mutable -> Ast_414.Asttypes.Mutable -and copy_injectivity : - Ast_413.Asttypes.injectivity -> Ast_414.Asttypes.injectivity = - function - | Ast_413.Asttypes.Injective -> Ast_414.Asttypes.Injective - | Ast_413.Asttypes.NoInjectivity -> Ast_414.Asttypes.NoInjectivity -and copy_variance : Ast_413.Asttypes.variance -> Ast_414.Asttypes.variance = - function - | Ast_413.Asttypes.Covariant -> Ast_414.Asttypes.Covariant - | Ast_413.Asttypes.Contravariant -> Ast_414.Asttypes.Contravariant - | Ast_413.Asttypes.NoVariance -> Ast_414.Asttypes.NoVariance -and copy_value_description : - Ast_413.Parsetree.value_description -> Ast_414.Parsetree.value_description - = - fun - { Ast_413.Parsetree.pval_name = pval_name; - Ast_413.Parsetree.pval_type = pval_type; - Ast_413.Parsetree.pval_prim = pval_prim; - Ast_413.Parsetree.pval_attributes = pval_attributes; - Ast_413.Parsetree.pval_loc = pval_loc } - -> - { - Ast_414.Parsetree.pval_name = (copy_loc (fun x -> x) pval_name); - Ast_414.Parsetree.pval_type = (copy_core_type pval_type); - Ast_414.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - Ast_414.Parsetree.pval_attributes = (copy_attributes pval_attributes); - Ast_414.Parsetree.pval_loc = (copy_location pval_loc) - } -and copy_object_field_desc : - Ast_413.Parsetree.object_field_desc -> Ast_414.Parsetree.object_field_desc - = - function - | Ast_413.Parsetree.Otag (x0, x1) -> - Ast_414.Parsetree.Otag ((copy_loc copy_label x0), (copy_core_type x1)) - | Ast_413.Parsetree.Oinherit x0 -> - Ast_414.Parsetree.Oinherit (copy_core_type x0) -and copy_arg_label : Ast_413.Asttypes.arg_label -> Ast_414.Asttypes.arg_label - = - function - | Ast_413.Asttypes.Nolabel -> Ast_414.Asttypes.Nolabel - | Ast_413.Asttypes.Labelled x0 -> Ast_414.Asttypes.Labelled x0 - | Ast_413.Asttypes.Optional x0 -> Ast_414.Asttypes.Optional x0 -and copy_closed_flag : - Ast_413.Asttypes.closed_flag -> Ast_414.Asttypes.closed_flag = - function - | Ast_413.Asttypes.Closed -> Ast_414.Asttypes.Closed - | Ast_413.Asttypes.Open -> Ast_414.Asttypes.Open -and copy_label : Ast_413.Asttypes.label -> Ast_414.Asttypes.label = - fun x -> x -and copy_rec_flag : Ast_413.Asttypes.rec_flag -> Ast_414.Asttypes.rec_flag = - function - | Ast_413.Asttypes.Nonrecursive -> Ast_414.Asttypes.Nonrecursive - | Ast_413.Asttypes.Recursive -> Ast_414.Asttypes.Recursive -and copy_constant : Ast_413.Parsetree.constant -> Ast_414.Parsetree.constant - = - function - | Ast_413.Parsetree.Pconst_integer (x0, x1) -> - Ast_414.Parsetree.Pconst_integer (x0, (Option.map (fun x -> x) x1)) - | Ast_413.Parsetree.Pconst_char x0 -> Ast_414.Parsetree.Pconst_char x0 - | Ast_413.Parsetree.Pconst_string (x0, x1, x2) -> - Ast_414.Parsetree.Pconst_string - (x0, (copy_location x1), (Option.map (fun x -> x) x2)) - | Ast_413.Parsetree.Pconst_float (x0, x1) -> - Ast_414.Parsetree.Pconst_float (x0, (Option.map (fun x -> x) x1)) -and copy_Longident_t : Longident.t -> Longident.t = - function - | Longident.Lident x0 -> Longident.Lident x0 - | Longident.Ldot (x0, x1) -> Longident.Ldot ((copy_Longident_t x0), x1) - | Longident.Lapply (x0, x1) -> - Longident.Lapply ((copy_Longident_t x0), (copy_Longident_t x1)) -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 Ast_413.Asttypes.loc -> 'g0 Ast_414.Asttypes.loc - = - fun f0 -> - fun { Ast_413.Asttypes.txt = txt; Ast_413.Asttypes.loc = loc } -> - { - Ast_414.Asttypes.txt = (f0 txt); - Ast_414.Asttypes.loc = (copy_location loc) - } -and copy_location : Location.t -> Location.t = - fun - { Location.loc_start = loc_start; Location.loc_end = loc_end; - Location.loc_ghost = loc_ghost } - -> - { - Location.loc_start = (copy_position loc_start); - Location.loc_end = (copy_position loc_end); - Location.loc_ghost = loc_ghost - } -and copy_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum - } diff --git a/src/vendored-omp/src/migrate_parsetree_414_413.ml b/src/vendored-omp/src/migrate_parsetree_414_413.ml index 4b5a0561a..16d0b4948 100644 --- a/src/vendored-omp/src/migrate_parsetree_414_413.ml +++ b/src/vendored-omp/src/migrate_parsetree_414_413.ml @@ -15,131 +15,3 @@ include Migrate_parsetree_414_413_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload"; - "binding_op"; "module_substitution"; "open_declaration"; "type_exception"; - "constant" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - binding_op; - module_substitution; - open_declaration; - type_exception; - constant; - (*$*) - } as mapper) -> - - let module Def = Migrate_parsetree_def in - let module R = Migrate_parsetree_413_414_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> List.map copy_case (cases mapper (List.map R.copy_case x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expression (expr mapper (R.copy_expression x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pattern (pat mapper (R.copy_pattern x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_core_type (typ mapper (R.copy_core_type x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - binding_op = (fun _ x -> copy_binding_op (binding_op mapper (R.copy_binding_op x))); - module_substitution = (fun _ x -> copy_module_substitution (module_substitution mapper (R.copy_module_substitution x))); - open_declaration = (fun _ x -> copy_open_declaration (open_declaration mapper (R.copy_open_declaration x))); - type_exception = (fun _ x -> copy_type_exception (type_exception mapper (R.copy_type_exception x))); - constant = (fun _ x -> copy_constant (constant mapper (R.copy_constant x))); - (*$*) - } - diff --git a/src/vendored-omp/src/migrate_parsetree_414_413_migrate.ml b/src/vendored-omp/src/migrate_parsetree_414_413_migrate.ml index 9556e3c56..cfbd9a9d0 100644 --- a/src/vendored-omp/src/migrate_parsetree_414_413_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_414_413_migrate.ml @@ -1,14 +1,6 @@ open Stdlib0 - module From = Ast_414 module To = Ast_413 - - -module Def = Migrate_parsetree_def - -let migration_error location feature = - raise (Def.Migration_error (feature, location)) - let rec copy_out_type_extension : Ast_414.Outcometree.out_type_extension -> Ast_413.Outcometree.out_type_extension @@ -164,6 +156,11 @@ and copy_out_extension_constructor : (Option.map copy_out_type oext_ret_type); Ast_413.Outcometree.oext_private = (copy_private_flag oext_private) } +and copy_private_flag : + Ast_414.Asttypes.private_flag -> Ast_413.Asttypes.private_flag = + function + | Ast_414.Asttypes.Private -> Ast_413.Asttypes.Private + | Ast_414.Asttypes.Public -> Ast_413.Asttypes.Public and copy_out_rec_status : Ast_414.Outcometree.out_rec_status -> Ast_413.Outcometree.out_rec_status = function @@ -200,6 +197,16 @@ and copy_out_type_param : fun x -> let (x0, x1) = x in (x0, (let (x0, x1) = x1 in ((copy_variance x0), (copy_injectivity x1)))) +and copy_injectivity : + Ast_414.Asttypes.injectivity -> Ast_413.Asttypes.injectivity = + function + | Ast_414.Asttypes.Injective -> Ast_413.Asttypes.Injective + | Ast_414.Asttypes.NoInjectivity -> Ast_413.Asttypes.NoInjectivity +and copy_variance : Ast_414.Asttypes.variance -> Ast_413.Asttypes.variance = + function + | Ast_414.Asttypes.Covariant -> Ast_413.Asttypes.Covariant + | Ast_414.Asttypes.Contravariant -> Ast_413.Asttypes.Contravariant + | Ast_414.Asttypes.NoVariance -> Ast_413.Asttypes.NoVariance and copy_out_type : Ast_414.Outcometree.out_type -> Ast_413.Outcometree.out_type = function @@ -249,7 +256,8 @@ and copy_out_type : | Ast_414.Outcometree.Otyp_module (x0, x1) -> Ast_413.Outcometree.Otyp_module ((copy_out_ident x0), - (List.map (fun (x0, x1) -> x0, (copy_out_type x1)) x1)) + (List.map (fun x -> let (x0, x1) = x in (x0, (copy_out_type x1))) + x1)) | Ast_414.Outcometree.Otyp_attribute (x0, x1) -> Ast_413.Outcometree.Otyp_attribute ((copy_out_type x0), (copy_out_attribute x1)) @@ -320,1224 +328,3 @@ and copy_out_name : Ast_414.Outcometree.out_name -> Ast_413.Outcometree.out_name = fun { Ast_414.Outcometree.printed_name = printed_name } -> { Ast_413.Outcometree.printed_name = printed_name } -and copy_toplevel_phrase : - Ast_414.Parsetree.toplevel_phrase -> Ast_413.Parsetree.toplevel_phrase = - function - | Ast_414.Parsetree.Ptop_def x0 -> - Ast_413.Parsetree.Ptop_def (copy_structure x0) - | Ast_414.Parsetree.Ptop_dir x0 -> - Ast_413.Parsetree.Ptop_dir (copy_toplevel_directive x0) -and copy_toplevel_directive : - Ast_414.Parsetree.toplevel_directive -> - Ast_413.Parsetree.toplevel_directive - = - fun - { Ast_414.Parsetree.pdir_name = pdir_name; - Ast_414.Parsetree.pdir_arg = pdir_arg; - Ast_414.Parsetree.pdir_loc = pdir_loc } - -> - { - Ast_413.Parsetree.pdir_name = (copy_loc (fun x -> x) pdir_name); - Ast_413.Parsetree.pdir_arg = - (Option.map copy_directive_argument pdir_arg); - Ast_413.Parsetree.pdir_loc = (copy_location pdir_loc) - } -and copy_directive_argument : - Ast_414.Parsetree.directive_argument -> - Ast_413.Parsetree.directive_argument - = - fun - { Ast_414.Parsetree.pdira_desc = pdira_desc; - Ast_414.Parsetree.pdira_loc = pdira_loc } - -> - { - Ast_413.Parsetree.pdira_desc = - (copy_directive_argument_desc pdira_desc); - Ast_413.Parsetree.pdira_loc = (copy_location pdira_loc) - } -and copy_directive_argument_desc : - Ast_414.Parsetree.directive_argument_desc -> - Ast_413.Parsetree.directive_argument_desc - = - function - | Ast_414.Parsetree.Pdir_string x0 -> Ast_413.Parsetree.Pdir_string x0 - | Ast_414.Parsetree.Pdir_int (x0, x1) -> - Ast_413.Parsetree.Pdir_int (x0, (Option.map (fun x -> x) x1)) - | Ast_414.Parsetree.Pdir_ident x0 -> - Ast_413.Parsetree.Pdir_ident (copy_Longident_t x0) - | Ast_414.Parsetree.Pdir_bool x0 -> Ast_413.Parsetree.Pdir_bool x0 -and copy_expression : - Ast_414.Parsetree.expression -> Ast_413.Parsetree.expression = - fun - { Ast_414.Parsetree.pexp_desc = pexp_desc; - Ast_414.Parsetree.pexp_loc = pexp_loc; - Ast_414.Parsetree.pexp_loc_stack = pexp_loc_stack; - Ast_414.Parsetree.pexp_attributes = pexp_attributes } - -> - { - Ast_413.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - Ast_413.Parsetree.pexp_loc = (copy_location pexp_loc); - Ast_413.Parsetree.pexp_loc_stack = (copy_location_stack pexp_loc_stack); - Ast_413.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } -and copy_expression_desc : - Ast_414.Parsetree.expression_desc -> Ast_413.Parsetree.expression_desc = - function - | Ast_414.Parsetree.Pexp_ident x0 -> - Ast_413.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) - | Ast_414.Parsetree.Pexp_constant x0 -> - Ast_413.Parsetree.Pexp_constant (copy_constant x0) - | Ast_414.Parsetree.Pexp_let (x0, x1, x2) -> - Ast_413.Parsetree.Pexp_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_expression x2)) - | Ast_414.Parsetree.Pexp_function x0 -> - Ast_413.Parsetree.Pexp_function (List.map copy_case x0) - | Ast_414.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_413.Parsetree.Pexp_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_expression x3)) - | Ast_414.Parsetree.Pexp_apply (x0, x1) -> - Ast_413.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_414.Parsetree.Pexp_match (x0, x1) -> - Ast_413.Parsetree.Pexp_match - ((copy_expression x0), (List.map copy_case x1)) - | Ast_414.Parsetree.Pexp_try (x0, x1) -> - Ast_413.Parsetree.Pexp_try - ((copy_expression x0), (List.map copy_case x1)) - | Ast_414.Parsetree.Pexp_tuple x0 -> - Ast_413.Parsetree.Pexp_tuple (List.map copy_expression x0) - | Ast_414.Parsetree.Pexp_construct (x0, x1) -> - Ast_413.Parsetree.Pexp_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_expression x1)) - | Ast_414.Parsetree.Pexp_variant (x0, x1) -> - Ast_413.Parsetree.Pexp_variant - ((copy_label x0), (Option.map copy_expression x1)) - | Ast_414.Parsetree.Pexp_record (x0, x1) -> - Ast_413.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_expression x1))) x0), - (Option.map copy_expression x1)) - | Ast_414.Parsetree.Pexp_field (x0, x1) -> - Ast_413.Parsetree.Pexp_field - ((copy_expression x0), (copy_loc copy_Longident_t x1)) - | Ast_414.Parsetree.Pexp_setfield (x0, x1, x2) -> - Ast_413.Parsetree.Pexp_setfield - ((copy_expression x0), (copy_loc copy_Longident_t x1), - (copy_expression x2)) - | Ast_414.Parsetree.Pexp_array x0 -> - Ast_413.Parsetree.Pexp_array (List.map copy_expression x0) - | Ast_414.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> - Ast_413.Parsetree.Pexp_ifthenelse - ((copy_expression x0), (copy_expression x1), - (Option.map copy_expression x2)) - | Ast_414.Parsetree.Pexp_sequence (x0, x1) -> - Ast_413.Parsetree.Pexp_sequence - ((copy_expression x0), (copy_expression x1)) - | Ast_414.Parsetree.Pexp_while (x0, x1) -> - Ast_413.Parsetree.Pexp_while - ((copy_expression x0), (copy_expression x1)) - | Ast_414.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> - Ast_413.Parsetree.Pexp_for - ((copy_pattern x0), (copy_expression x1), (copy_expression x2), - (copy_direction_flag x3), (copy_expression x4)) - | Ast_414.Parsetree.Pexp_constraint (x0, x1) -> - Ast_413.Parsetree.Pexp_constraint - ((copy_expression x0), (copy_core_type x1)) - | Ast_414.Parsetree.Pexp_coerce (x0, x1, x2) -> - Ast_413.Parsetree.Pexp_coerce - ((copy_expression x0), (Option.map copy_core_type x1), - (copy_core_type x2)) - | Ast_414.Parsetree.Pexp_send (x0, x1) -> - Ast_413.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc copy_label x1)) - | Ast_414.Parsetree.Pexp_new x0 -> - Ast_413.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) - | Ast_414.Parsetree.Pexp_setinstvar (x0, x1) -> - Ast_413.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), (copy_expression x1)) - | Ast_414.Parsetree.Pexp_override x0 -> - Ast_413.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_label x0), (copy_expression x1))) x0) - | Ast_414.Parsetree.Pexp_letmodule (x0, x1, x2) -> - Ast_413.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_expr x1), (copy_expression x2)) - | Ast_414.Parsetree.Pexp_letexception (x0, x1) -> - Ast_413.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), (copy_expression x1)) - | Ast_414.Parsetree.Pexp_assert x0 -> - Ast_413.Parsetree.Pexp_assert (copy_expression x0) - | Ast_414.Parsetree.Pexp_lazy x0 -> - Ast_413.Parsetree.Pexp_lazy (copy_expression x0) - | Ast_414.Parsetree.Pexp_poly (x0, x1) -> - Ast_413.Parsetree.Pexp_poly - ((copy_expression x0), (Option.map copy_core_type x1)) - | Ast_414.Parsetree.Pexp_object x0 -> - Ast_413.Parsetree.Pexp_object (copy_class_structure x0) - | Ast_414.Parsetree.Pexp_newtype (x0, x1) -> - Ast_413.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | Ast_414.Parsetree.Pexp_pack x0 -> - Ast_413.Parsetree.Pexp_pack (copy_module_expr x0) - | Ast_414.Parsetree.Pexp_open (x0, x1) -> - Ast_413.Parsetree.Pexp_open - ((copy_open_declaration x0), (copy_expression x1)) - | Ast_414.Parsetree.Pexp_letop x0 -> - Ast_413.Parsetree.Pexp_letop (copy_letop x0) - | Ast_414.Parsetree.Pexp_extension x0 -> - Ast_413.Parsetree.Pexp_extension (copy_extension x0) - | Ast_414.Parsetree.Pexp_unreachable -> Ast_413.Parsetree.Pexp_unreachable -and copy_letop : Ast_414.Parsetree.letop -> Ast_413.Parsetree.letop = - fun - { Ast_414.Parsetree.let_ = let_; Ast_414.Parsetree.ands = ands; - Ast_414.Parsetree.body = body } - -> - { - Ast_413.Parsetree.let_ = (copy_binding_op let_); - Ast_413.Parsetree.ands = (List.map copy_binding_op ands); - Ast_413.Parsetree.body = (copy_expression body) - } -and copy_binding_op : - Ast_414.Parsetree.binding_op -> Ast_413.Parsetree.binding_op = - fun - { Ast_414.Parsetree.pbop_op = pbop_op; - Ast_414.Parsetree.pbop_pat = pbop_pat; - Ast_414.Parsetree.pbop_exp = pbop_exp; - Ast_414.Parsetree.pbop_loc = pbop_loc } - -> - { - Ast_413.Parsetree.pbop_op = (copy_loc (fun x -> x) pbop_op); - Ast_413.Parsetree.pbop_pat = (copy_pattern pbop_pat); - Ast_413.Parsetree.pbop_exp = (copy_expression pbop_exp); - Ast_413.Parsetree.pbop_loc = (copy_location pbop_loc) - } -and copy_direction_flag : - Ast_414.Asttypes.direction_flag -> Ast_413.Asttypes.direction_flag = - function - | Ast_414.Asttypes.Upto -> Ast_413.Asttypes.Upto - | Ast_414.Asttypes.Downto -> Ast_413.Asttypes.Downto -and copy_case : Ast_414.Parsetree.case -> Ast_413.Parsetree.case = - fun - { Ast_414.Parsetree.pc_lhs = pc_lhs; - Ast_414.Parsetree.pc_guard = pc_guard; - Ast_414.Parsetree.pc_rhs = pc_rhs } - -> - { - Ast_413.Parsetree.pc_lhs = (copy_pattern pc_lhs); - Ast_413.Parsetree.pc_guard = (Option.map copy_expression pc_guard); - Ast_413.Parsetree.pc_rhs = (copy_expression pc_rhs) - } -and copy_value_binding : - Ast_414.Parsetree.value_binding -> Ast_413.Parsetree.value_binding = - fun - { Ast_414.Parsetree.pvb_pat = pvb_pat; - Ast_414.Parsetree.pvb_expr = pvb_expr; - Ast_414.Parsetree.pvb_attributes = pvb_attributes; - Ast_414.Parsetree.pvb_loc = pvb_loc } - -> - { - Ast_413.Parsetree.pvb_pat = (copy_pattern pvb_pat); - Ast_413.Parsetree.pvb_expr = (copy_expression pvb_expr); - Ast_413.Parsetree.pvb_attributes = (copy_attributes pvb_attributes); - Ast_413.Parsetree.pvb_loc = (copy_location pvb_loc) - } -and copy_pattern : Ast_414.Parsetree.pattern -> Ast_413.Parsetree.pattern = - fun - { Ast_414.Parsetree.ppat_desc = ppat_desc; - Ast_414.Parsetree.ppat_loc = ppat_loc; - Ast_414.Parsetree.ppat_loc_stack = ppat_loc_stack; - Ast_414.Parsetree.ppat_attributes = ppat_attributes } - -> - { - Ast_413.Parsetree.ppat_desc = (copy_pattern_desc ppat_desc); - Ast_413.Parsetree.ppat_loc = (copy_location ppat_loc); - Ast_413.Parsetree.ppat_loc_stack = (copy_location_stack ppat_loc_stack); - Ast_413.Parsetree.ppat_attributes = (copy_attributes ppat_attributes) - } -and copy_pattern_desc : - Ast_414.Parsetree.pattern_desc -> Ast_413.Parsetree.pattern_desc = - function - | Ast_414.Parsetree.Ppat_any -> Ast_413.Parsetree.Ppat_any - | Ast_414.Parsetree.Ppat_var x0 -> - Ast_413.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | Ast_414.Parsetree.Ppat_alias (x0, x1) -> - Ast_413.Parsetree.Ppat_alias - ((copy_pattern x0), (copy_loc (fun x -> x) x1)) - | Ast_414.Parsetree.Ppat_constant x0 -> - Ast_413.Parsetree.Ppat_constant (copy_constant x0) - | Ast_414.Parsetree.Ppat_interval (x0, x1) -> - Ast_413.Parsetree.Ppat_interval - ((copy_constant x0), (copy_constant x1)) - | Ast_414.Parsetree.Ppat_tuple x0 -> - Ast_413.Parsetree.Ppat_tuple (List.map copy_pattern x0) - | Ast_414.Parsetree.Ppat_construct (x0, x1) -> - Ast_413.Parsetree.Ppat_construct - ((copy_loc copy_Longident_t x0), - (Option.map - (fun x -> - let (x0, x1) = x in - x0, copy_pattern x1) x1)) - | Ast_414.Parsetree.Ppat_variant (x0, x1) -> - Ast_413.Parsetree.Ppat_variant - ((copy_label x0), (Option.map copy_pattern x1)) - | Ast_414.Parsetree.Ppat_record (x0, x1) -> - Ast_413.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | Ast_414.Parsetree.Ppat_array x0 -> - Ast_413.Parsetree.Ppat_array (List.map copy_pattern x0) - | Ast_414.Parsetree.Ppat_or (x0, x1) -> - Ast_413.Parsetree.Ppat_or ((copy_pattern x0), (copy_pattern x1)) - | Ast_414.Parsetree.Ppat_constraint (x0, x1) -> - Ast_413.Parsetree.Ppat_constraint - ((copy_pattern x0), (copy_core_type x1)) - | Ast_414.Parsetree.Ppat_type x0 -> - Ast_413.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) - | Ast_414.Parsetree.Ppat_lazy x0 -> - Ast_413.Parsetree.Ppat_lazy (copy_pattern x0) - | Ast_414.Parsetree.Ppat_unpack x0 -> - Ast_413.Parsetree.Ppat_unpack - (copy_loc (fun x -> Option.map (fun x -> x) x) x0) - | Ast_414.Parsetree.Ppat_exception x0 -> - Ast_413.Parsetree.Ppat_exception (copy_pattern x0) - | Ast_414.Parsetree.Ppat_extension x0 -> - Ast_413.Parsetree.Ppat_extension (copy_extension x0) - | Ast_414.Parsetree.Ppat_open (x0, x1) -> - Ast_413.Parsetree.Ppat_open - ((copy_loc copy_Longident_t x0), (copy_pattern x1)) -and copy_core_type : - Ast_414.Parsetree.core_type -> Ast_413.Parsetree.core_type = - fun - { Ast_414.Parsetree.ptyp_desc = ptyp_desc; - Ast_414.Parsetree.ptyp_loc = ptyp_loc; - Ast_414.Parsetree.ptyp_loc_stack = ptyp_loc_stack; - Ast_414.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - Ast_413.Parsetree.ptyp_desc = (copy_core_type_desc ptyp_desc); - Ast_413.Parsetree.ptyp_loc = (copy_location ptyp_loc); - Ast_413.Parsetree.ptyp_loc_stack = (copy_location_stack ptyp_loc_stack); - Ast_413.Parsetree.ptyp_attributes = (copy_attributes ptyp_attributes) - } -and copy_location_stack : - Ast_414.Parsetree.location_stack -> Ast_413.Parsetree.location_stack = - fun x -> List.map copy_location x -and copy_core_type_desc : - Ast_414.Parsetree.core_type_desc -> Ast_413.Parsetree.core_type_desc = - function - | Ast_414.Parsetree.Ptyp_any -> Ast_413.Parsetree.Ptyp_any - | Ast_414.Parsetree.Ptyp_var x0 -> Ast_413.Parsetree.Ptyp_var x0 - | Ast_414.Parsetree.Ptyp_arrow (x0, x1, x2) -> - Ast_413.Parsetree.Ptyp_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_core_type x2)) - | Ast_414.Parsetree.Ptyp_tuple x0 -> - Ast_413.Parsetree.Ptyp_tuple (List.map copy_core_type x0) - | Ast_414.Parsetree.Ptyp_constr (x0, x1) -> - Ast_413.Parsetree.Ptyp_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_414.Parsetree.Ptyp_object (x0, x1) -> - Ast_413.Parsetree.Ptyp_object - ((List.map copy_object_field x0), (copy_closed_flag x1)) - | Ast_414.Parsetree.Ptyp_class (x0, x1) -> - Ast_413.Parsetree.Ptyp_class - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_414.Parsetree.Ptyp_alias (x0, x1) -> - Ast_413.Parsetree.Ptyp_alias ((copy_core_type x0), x1) - | Ast_414.Parsetree.Ptyp_variant (x0, x1, x2) -> - Ast_413.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), (copy_closed_flag x1), - (Option.map (fun x -> List.map copy_label x) x2)) - | Ast_414.Parsetree.Ptyp_poly (x0, x1) -> - Ast_413.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | Ast_414.Parsetree.Ptyp_package x0 -> - Ast_413.Parsetree.Ptyp_package (copy_package_type x0) - | Ast_414.Parsetree.Ptyp_extension x0 -> - Ast_413.Parsetree.Ptyp_extension (copy_extension x0) -and copy_package_type : - Ast_414.Parsetree.package_type -> Ast_413.Parsetree.package_type = - fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_core_type x1))) x1)) -and copy_row_field : - Ast_414.Parsetree.row_field -> Ast_413.Parsetree.row_field = - fun - { Ast_414.Parsetree.prf_desc = prf_desc; - Ast_414.Parsetree.prf_loc = prf_loc; - Ast_414.Parsetree.prf_attributes = prf_attributes } - -> - { - Ast_413.Parsetree.prf_desc = (copy_row_field_desc prf_desc); - Ast_413.Parsetree.prf_loc = (copy_location prf_loc); - Ast_413.Parsetree.prf_attributes = (copy_attributes prf_attributes) - } -and copy_row_field_desc : - Ast_414.Parsetree.row_field_desc -> Ast_413.Parsetree.row_field_desc = - function - | Ast_414.Parsetree.Rtag (x0, x1, x2) -> - Ast_413.Parsetree.Rtag - ((copy_loc copy_label x0), x1, (List.map copy_core_type x2)) - | Ast_414.Parsetree.Rinherit x0 -> - Ast_413.Parsetree.Rinherit (copy_core_type x0) -and copy_object_field : - Ast_414.Parsetree.object_field -> Ast_413.Parsetree.object_field = - fun - { Ast_414.Parsetree.pof_desc = pof_desc; - Ast_414.Parsetree.pof_loc = pof_loc; - Ast_414.Parsetree.pof_attributes = pof_attributes } - -> - { - Ast_413.Parsetree.pof_desc = (copy_object_field_desc pof_desc); - Ast_413.Parsetree.pof_loc = (copy_location pof_loc); - Ast_413.Parsetree.pof_attributes = (copy_attributes pof_attributes) - } -and copy_attributes : - Ast_414.Parsetree.attributes -> Ast_413.Parsetree.attributes = - fun x -> List.map copy_attribute x -and copy_attribute : - Ast_414.Parsetree.attribute -> Ast_413.Parsetree.attribute = - fun - { Ast_414.Parsetree.attr_name = attr_name; - Ast_414.Parsetree.attr_payload = attr_payload; - Ast_414.Parsetree.attr_loc = attr_loc } - -> - { - Ast_413.Parsetree.attr_name = (copy_loc (fun x -> x) attr_name); - Ast_413.Parsetree.attr_payload = (copy_payload attr_payload); - Ast_413.Parsetree.attr_loc = (copy_location attr_loc) - } -and copy_payload : Ast_414.Parsetree.payload -> Ast_413.Parsetree.payload = - function - | Ast_414.Parsetree.PStr x0 -> Ast_413.Parsetree.PStr (copy_structure x0) - | Ast_414.Parsetree.PSig x0 -> Ast_413.Parsetree.PSig (copy_signature x0) - | Ast_414.Parsetree.PTyp x0 -> Ast_413.Parsetree.PTyp (copy_core_type x0) - | Ast_414.Parsetree.PPat (x0, x1) -> - Ast_413.Parsetree.PPat - ((copy_pattern x0), (Option.map copy_expression x1)) -and copy_structure : - Ast_414.Parsetree.structure -> Ast_413.Parsetree.structure = - fun x -> List.map copy_structure_item x -and copy_structure_item : - Ast_414.Parsetree.structure_item -> Ast_413.Parsetree.structure_item = - fun - { Ast_414.Parsetree.pstr_desc = pstr_desc; - Ast_414.Parsetree.pstr_loc = pstr_loc } - -> - { - Ast_413.Parsetree.pstr_desc = (copy_structure_item_desc pstr_desc); - Ast_413.Parsetree.pstr_loc = (copy_location pstr_loc) - } -and copy_structure_item_desc : - Ast_414.Parsetree.structure_item_desc -> - Ast_413.Parsetree.structure_item_desc - = - function - | Ast_414.Parsetree.Pstr_eval (x0, x1) -> - Ast_413.Parsetree.Pstr_eval - ((copy_expression x0), (copy_attributes x1)) - | Ast_414.Parsetree.Pstr_value (x0, x1) -> - Ast_413.Parsetree.Pstr_value - ((copy_rec_flag x0), (List.map copy_value_binding x1)) - | Ast_414.Parsetree.Pstr_primitive x0 -> - Ast_413.Parsetree.Pstr_primitive (copy_value_description x0) - | Ast_414.Parsetree.Pstr_type (x0, x1) -> - Ast_413.Parsetree.Pstr_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_414.Parsetree.Pstr_typext x0 -> - Ast_413.Parsetree.Pstr_typext (copy_type_extension x0) - | Ast_414.Parsetree.Pstr_exception x0 -> - Ast_413.Parsetree.Pstr_exception (copy_type_exception x0) - | Ast_414.Parsetree.Pstr_module x0 -> - Ast_413.Parsetree.Pstr_module (copy_module_binding x0) - | Ast_414.Parsetree.Pstr_recmodule x0 -> - Ast_413.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) - | Ast_414.Parsetree.Pstr_modtype x0 -> - Ast_413.Parsetree.Pstr_modtype (copy_module_type_declaration x0) - | Ast_414.Parsetree.Pstr_open x0 -> - Ast_413.Parsetree.Pstr_open (copy_open_declaration x0) - | Ast_414.Parsetree.Pstr_class x0 -> - Ast_413.Parsetree.Pstr_class (List.map copy_class_declaration x0) - | Ast_414.Parsetree.Pstr_class_type x0 -> - Ast_413.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | Ast_414.Parsetree.Pstr_include x0 -> - Ast_413.Parsetree.Pstr_include (copy_include_declaration x0) - | Ast_414.Parsetree.Pstr_attribute x0 -> - Ast_413.Parsetree.Pstr_attribute (copy_attribute x0) - | Ast_414.Parsetree.Pstr_extension (x0, x1) -> - Ast_413.Parsetree.Pstr_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_include_declaration : - Ast_414.Parsetree.include_declaration -> - Ast_413.Parsetree.include_declaration - = fun x -> copy_include_infos copy_module_expr x -and copy_class_declaration : - Ast_414.Parsetree.class_declaration -> Ast_413.Parsetree.class_declaration - = fun x -> copy_class_infos copy_class_expr x -and copy_class_expr : - Ast_414.Parsetree.class_expr -> Ast_413.Parsetree.class_expr = - fun - { Ast_414.Parsetree.pcl_desc = pcl_desc; - Ast_414.Parsetree.pcl_loc = pcl_loc; - Ast_414.Parsetree.pcl_attributes = pcl_attributes } - -> - { - Ast_413.Parsetree.pcl_desc = (copy_class_expr_desc pcl_desc); - Ast_413.Parsetree.pcl_loc = (copy_location pcl_loc); - Ast_413.Parsetree.pcl_attributes = (copy_attributes pcl_attributes) - } -and copy_class_expr_desc : - Ast_414.Parsetree.class_expr_desc -> Ast_413.Parsetree.class_expr_desc = - function - | Ast_414.Parsetree.Pcl_constr (x0, x1) -> - Ast_413.Parsetree.Pcl_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_414.Parsetree.Pcl_structure x0 -> - Ast_413.Parsetree.Pcl_structure (copy_class_structure x0) - | Ast_414.Parsetree.Pcl_fun (x0, x1, x2, x3) -> - Ast_413.Parsetree.Pcl_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_class_expr x3)) - | Ast_414.Parsetree.Pcl_apply (x0, x1) -> - Ast_413.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_414.Parsetree.Pcl_let (x0, x1, x2) -> - Ast_413.Parsetree.Pcl_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_class_expr x2)) - | Ast_414.Parsetree.Pcl_constraint (x0, x1) -> - Ast_413.Parsetree.Pcl_constraint - ((copy_class_expr x0), (copy_class_type x1)) - | Ast_414.Parsetree.Pcl_extension x0 -> - Ast_413.Parsetree.Pcl_extension (copy_extension x0) - | Ast_414.Parsetree.Pcl_open (x0, x1) -> - Ast_413.Parsetree.Pcl_open - ((copy_open_description x0), (copy_class_expr x1)) -and copy_class_structure : - Ast_414.Parsetree.class_structure -> Ast_413.Parsetree.class_structure = - fun - { Ast_414.Parsetree.pcstr_self = pcstr_self; - Ast_414.Parsetree.pcstr_fields = pcstr_fields } - -> - { - Ast_413.Parsetree.pcstr_self = (copy_pattern pcstr_self); - Ast_413.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } -and copy_class_field : - Ast_414.Parsetree.class_field -> Ast_413.Parsetree.class_field = - fun - { Ast_414.Parsetree.pcf_desc = pcf_desc; - Ast_414.Parsetree.pcf_loc = pcf_loc; - Ast_414.Parsetree.pcf_attributes = pcf_attributes } - -> - { - Ast_413.Parsetree.pcf_desc = (copy_class_field_desc pcf_desc); - Ast_413.Parsetree.pcf_loc = (copy_location pcf_loc); - Ast_413.Parsetree.pcf_attributes = (copy_attributes pcf_attributes) - } -and copy_class_field_desc : - Ast_414.Parsetree.class_field_desc -> Ast_413.Parsetree.class_field_desc = - function - | Ast_414.Parsetree.Pcf_inherit (x0, x1, x2) -> - Ast_413.Parsetree.Pcf_inherit - ((copy_override_flag x0), (copy_class_expr x1), - (Option.map (fun x -> copy_loc (fun x -> x) x) x2)) - | Ast_414.Parsetree.Pcf_val x0 -> - Ast_413.Parsetree.Pcf_val - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | Ast_414.Parsetree.Pcf_method x0 -> - Ast_413.Parsetree.Pcf_method - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_class_field_kind x2))) - | Ast_414.Parsetree.Pcf_constraint x0 -> - Ast_413.Parsetree.Pcf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_414.Parsetree.Pcf_initializer x0 -> - Ast_413.Parsetree.Pcf_initializer (copy_expression x0) - | Ast_414.Parsetree.Pcf_attribute x0 -> - Ast_413.Parsetree.Pcf_attribute (copy_attribute x0) - | Ast_414.Parsetree.Pcf_extension x0 -> - Ast_413.Parsetree.Pcf_extension (copy_extension x0) -and copy_class_field_kind : - Ast_414.Parsetree.class_field_kind -> Ast_413.Parsetree.class_field_kind = - function - | Ast_414.Parsetree.Cfk_virtual x0 -> - Ast_413.Parsetree.Cfk_virtual (copy_core_type x0) - | Ast_414.Parsetree.Cfk_concrete (x0, x1) -> - Ast_413.Parsetree.Cfk_concrete - ((copy_override_flag x0), (copy_expression x1)) -and copy_open_declaration : - Ast_414.Parsetree.open_declaration -> Ast_413.Parsetree.open_declaration = - fun x -> copy_open_infos copy_module_expr x -and copy_module_binding : - Ast_414.Parsetree.module_binding -> Ast_413.Parsetree.module_binding = - fun - { Ast_414.Parsetree.pmb_name = pmb_name; - Ast_414.Parsetree.pmb_expr = pmb_expr; - Ast_414.Parsetree.pmb_attributes = pmb_attributes; - Ast_414.Parsetree.pmb_loc = pmb_loc } - -> - { - Ast_413.Parsetree.pmb_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name); - Ast_413.Parsetree.pmb_expr = (copy_module_expr pmb_expr); - Ast_413.Parsetree.pmb_attributes = (copy_attributes pmb_attributes); - Ast_413.Parsetree.pmb_loc = (copy_location pmb_loc) - } -and copy_module_expr : - Ast_414.Parsetree.module_expr -> Ast_413.Parsetree.module_expr = - fun - { Ast_414.Parsetree.pmod_desc = pmod_desc; - Ast_414.Parsetree.pmod_loc = pmod_loc; - Ast_414.Parsetree.pmod_attributes = pmod_attributes } - -> - { - Ast_413.Parsetree.pmod_desc = (copy_module_expr_desc pmod_desc); - Ast_413.Parsetree.pmod_loc = (copy_location pmod_loc); - Ast_413.Parsetree.pmod_attributes = (copy_attributes pmod_attributes) - } -and copy_module_expr_desc : - Ast_414.Parsetree.module_expr_desc -> Ast_413.Parsetree.module_expr_desc = - function - | Ast_414.Parsetree.Pmod_ident x0 -> - Ast_413.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) - | Ast_414.Parsetree.Pmod_structure x0 -> - Ast_413.Parsetree.Pmod_structure (copy_structure x0) - | Ast_414.Parsetree.Pmod_functor (x0, x1) -> - Ast_413.Parsetree.Pmod_functor - ((copy_functor_parameter x0), (copy_module_expr x1)) - | Ast_414.Parsetree.Pmod_apply (x0, x1) -> - Ast_413.Parsetree.Pmod_apply - ((copy_module_expr x0), (copy_module_expr x1)) - | Ast_414.Parsetree.Pmod_constraint (x0, x1) -> - Ast_413.Parsetree.Pmod_constraint - ((copy_module_expr x0), (copy_module_type x1)) - | Ast_414.Parsetree.Pmod_unpack x0 -> - Ast_413.Parsetree.Pmod_unpack (copy_expression x0) - | Ast_414.Parsetree.Pmod_extension x0 -> - Ast_413.Parsetree.Pmod_extension (copy_extension x0) -and copy_functor_parameter : - Ast_414.Parsetree.functor_parameter -> Ast_413.Parsetree.functor_parameter - = - function - | Ast_414.Parsetree.Unit -> Ast_413.Parsetree.Unit - | Ast_414.Parsetree.Named (x0, x1) -> - Ast_413.Parsetree.Named - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_type x1)) -and copy_module_type : - Ast_414.Parsetree.module_type -> Ast_413.Parsetree.module_type = - fun - { Ast_414.Parsetree.pmty_desc = pmty_desc; - Ast_414.Parsetree.pmty_loc = pmty_loc; - Ast_414.Parsetree.pmty_attributes = pmty_attributes } - -> - { - Ast_413.Parsetree.pmty_desc = (copy_module_type_desc pmty_desc); - Ast_413.Parsetree.pmty_loc = (copy_location pmty_loc); - Ast_413.Parsetree.pmty_attributes = (copy_attributes pmty_attributes) - } -and copy_module_type_desc : - Ast_414.Parsetree.module_type_desc -> Ast_413.Parsetree.module_type_desc = - function - | Ast_414.Parsetree.Pmty_ident x0 -> - Ast_413.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) - | Ast_414.Parsetree.Pmty_signature x0 -> - Ast_413.Parsetree.Pmty_signature (copy_signature x0) - | Ast_414.Parsetree.Pmty_functor (x0, x1) -> - Ast_413.Parsetree.Pmty_functor - ((copy_functor_parameter x0), (copy_module_type x1)) - | Ast_414.Parsetree.Pmty_with (x0, x1) -> - Ast_413.Parsetree.Pmty_with - ((copy_module_type x0), (List.map copy_with_constraint x1)) - | Ast_414.Parsetree.Pmty_typeof x0 -> - Ast_413.Parsetree.Pmty_typeof (copy_module_expr x0) - | Ast_414.Parsetree.Pmty_extension x0 -> - Ast_413.Parsetree.Pmty_extension (copy_extension x0) - | Ast_414.Parsetree.Pmty_alias x0 -> - Ast_413.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) -and copy_with_constraint : - Ast_414.Parsetree.with_constraint -> Ast_413.Parsetree.with_constraint = - function - | Ast_414.Parsetree.Pwith_type (x0, x1) -> - Ast_413.Parsetree.Pwith_type - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_414.Parsetree.Pwith_module (x0, x1) -> - Ast_413.Parsetree.Pwith_module - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) - | Ast_414.Parsetree.Pwith_modtype (_, x1) -> - migration_error x1.Ast_414.Parsetree.pmty_loc With_modtype - | Ast_414.Parsetree.Pwith_modtypesubst (_, x1) -> - migration_error x1.Ast_414.Parsetree.pmty_loc With_modtypesubst - | Ast_414.Parsetree.Pwith_typesubst (x0, x1) -> - Ast_413.Parsetree.Pwith_typesubst - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_414.Parsetree.Pwith_modsubst (x0, x1) -> - Ast_413.Parsetree.Pwith_modsubst - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) -and copy_signature : - Ast_414.Parsetree.signature -> Ast_413.Parsetree.signature = - fun x -> List.map copy_signature_item x -and copy_signature_item : - Ast_414.Parsetree.signature_item -> Ast_413.Parsetree.signature_item = - fun - { Ast_414.Parsetree.psig_desc = psig_desc; - Ast_414.Parsetree.psig_loc = psig_loc } - -> - { - Ast_413.Parsetree.psig_desc = (copy_signature_item_desc psig_desc); - Ast_413.Parsetree.psig_loc = (copy_location psig_loc) - } -and copy_signature_item_desc : - Ast_414.Parsetree.signature_item_desc -> - Ast_413.Parsetree.signature_item_desc - = - function - | Ast_414.Parsetree.Psig_value x0 -> - Ast_413.Parsetree.Psig_value (copy_value_description x0) - | Ast_414.Parsetree.Psig_type (x0, x1) -> - Ast_413.Parsetree.Psig_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_414.Parsetree.Psig_typesubst x0 -> - Ast_413.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) - | Ast_414.Parsetree.Psig_typext x0 -> - Ast_413.Parsetree.Psig_typext (copy_type_extension x0) - | Ast_414.Parsetree.Psig_exception x0 -> - Ast_413.Parsetree.Psig_exception (copy_type_exception x0) - | Ast_414.Parsetree.Psig_module x0 -> - Ast_413.Parsetree.Psig_module (copy_module_declaration x0) - | Ast_414.Parsetree.Psig_modsubst x0 -> - Ast_413.Parsetree.Psig_modsubst (copy_module_substitution x0) - | Ast_414.Parsetree.Psig_recmodule x0 -> - Ast_413.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) - | Ast_414.Parsetree.Psig_modtype x0 -> - Ast_413.Parsetree.Psig_modtype (copy_module_type_declaration x0) - | Ast_414.Parsetree.Psig_modtypesubst x0 -> - migration_error x0.Ast_414.Parsetree.pmtd_loc Psig_modtypesubst - | Ast_414.Parsetree.Psig_open x0 -> - Ast_413.Parsetree.Psig_open (copy_open_description x0) - | Ast_414.Parsetree.Psig_include x0 -> - Ast_413.Parsetree.Psig_include (copy_include_description x0) - | Ast_414.Parsetree.Psig_class x0 -> - Ast_413.Parsetree.Psig_class (List.map copy_class_description x0) - | Ast_414.Parsetree.Psig_class_type x0 -> - Ast_413.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | Ast_414.Parsetree.Psig_attribute x0 -> - Ast_413.Parsetree.Psig_attribute (copy_attribute x0) - | Ast_414.Parsetree.Psig_extension (x0, x1) -> - Ast_413.Parsetree.Psig_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_class_type_declaration : - Ast_414.Parsetree.class_type_declaration -> - Ast_413.Parsetree.class_type_declaration - = fun x -> copy_class_infos copy_class_type x -and copy_class_description : - Ast_414.Parsetree.class_description -> Ast_413.Parsetree.class_description - = fun x -> copy_class_infos copy_class_type x -and copy_class_type : - Ast_414.Parsetree.class_type -> Ast_413.Parsetree.class_type = - fun - { Ast_414.Parsetree.pcty_desc = pcty_desc; - Ast_414.Parsetree.pcty_loc = pcty_loc; - Ast_414.Parsetree.pcty_attributes = pcty_attributes } - -> - { - Ast_413.Parsetree.pcty_desc = (copy_class_type_desc pcty_desc); - Ast_413.Parsetree.pcty_loc = (copy_location pcty_loc); - Ast_413.Parsetree.pcty_attributes = (copy_attributes pcty_attributes) - } -and copy_class_type_desc : - Ast_414.Parsetree.class_type_desc -> Ast_413.Parsetree.class_type_desc = - function - | Ast_414.Parsetree.Pcty_constr (x0, x1) -> - Ast_413.Parsetree.Pcty_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_414.Parsetree.Pcty_signature x0 -> - Ast_413.Parsetree.Pcty_signature (copy_class_signature x0) - | Ast_414.Parsetree.Pcty_arrow (x0, x1, x2) -> - Ast_413.Parsetree.Pcty_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_class_type x2)) - | Ast_414.Parsetree.Pcty_extension x0 -> - Ast_413.Parsetree.Pcty_extension (copy_extension x0) - | Ast_414.Parsetree.Pcty_open (x0, x1) -> - Ast_413.Parsetree.Pcty_open - ((copy_open_description x0), (copy_class_type x1)) -and copy_class_signature : - Ast_414.Parsetree.class_signature -> Ast_413.Parsetree.class_signature = - fun - { Ast_414.Parsetree.pcsig_self = pcsig_self; - Ast_414.Parsetree.pcsig_fields = pcsig_fields } - -> - { - Ast_413.Parsetree.pcsig_self = (copy_core_type pcsig_self); - Ast_413.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } -and copy_class_type_field : - Ast_414.Parsetree.class_type_field -> Ast_413.Parsetree.class_type_field = - fun - { Ast_414.Parsetree.pctf_desc = pctf_desc; - Ast_414.Parsetree.pctf_loc = pctf_loc; - Ast_414.Parsetree.pctf_attributes = pctf_attributes } - -> - { - Ast_413.Parsetree.pctf_desc = (copy_class_type_field_desc pctf_desc); - Ast_413.Parsetree.pctf_loc = (copy_location pctf_loc); - Ast_413.Parsetree.pctf_attributes = (copy_attributes pctf_attributes) - } -and copy_class_type_field_desc : - Ast_414.Parsetree.class_type_field_desc -> - Ast_413.Parsetree.class_type_field_desc - = - function - | Ast_414.Parsetree.Pctf_inherit x0 -> - Ast_413.Parsetree.Pctf_inherit (copy_class_type x0) - | Ast_414.Parsetree.Pctf_val x0 -> - Ast_413.Parsetree.Pctf_val - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_414.Parsetree.Pctf_method x0 -> - Ast_413.Parsetree.Pctf_method - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_414.Parsetree.Pctf_constraint x0 -> - Ast_413.Parsetree.Pctf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_414.Parsetree.Pctf_attribute x0 -> - Ast_413.Parsetree.Pctf_attribute (copy_attribute x0) - | Ast_414.Parsetree.Pctf_extension x0 -> - Ast_413.Parsetree.Pctf_extension (copy_extension x0) -and copy_extension : - Ast_414.Parsetree.extension -> Ast_413.Parsetree.extension = - fun x -> - let (x0, x1) = x in ((copy_loc (fun x -> x) x0), (copy_payload x1)) -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_414.Parsetree.class_infos -> 'g0 Ast_413.Parsetree.class_infos - = - fun f0 -> - fun - { Ast_414.Parsetree.pci_virt = pci_virt; - Ast_414.Parsetree.pci_params = pci_params; - Ast_414.Parsetree.pci_name = pci_name; - Ast_414.Parsetree.pci_expr = pci_expr; - Ast_414.Parsetree.pci_loc = pci_loc; - Ast_414.Parsetree.pci_attributes = pci_attributes } - -> - { - Ast_413.Parsetree.pci_virt = (copy_virtual_flag pci_virt); - Ast_413.Parsetree.pci_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) pci_params); - Ast_413.Parsetree.pci_name = (copy_loc (fun x -> x) pci_name); - Ast_413.Parsetree.pci_expr = (f0 pci_expr); - Ast_413.Parsetree.pci_loc = (copy_location pci_loc); - Ast_413.Parsetree.pci_attributes = (copy_attributes pci_attributes) - } -and copy_virtual_flag : - Ast_414.Asttypes.virtual_flag -> Ast_413.Asttypes.virtual_flag = - function - | Ast_414.Asttypes.Virtual -> Ast_413.Asttypes.Virtual - | Ast_414.Asttypes.Concrete -> Ast_413.Asttypes.Concrete -and copy_include_description : - Ast_414.Parsetree.include_description -> - Ast_413.Parsetree.include_description - = fun x -> copy_include_infos copy_module_type x -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_414.Parsetree.include_infos -> - 'g0 Ast_413.Parsetree.include_infos - = - fun f0 -> - fun - { Ast_414.Parsetree.pincl_mod = pincl_mod; - Ast_414.Parsetree.pincl_loc = pincl_loc; - Ast_414.Parsetree.pincl_attributes = pincl_attributes } - -> - { - Ast_413.Parsetree.pincl_mod = (f0 pincl_mod); - Ast_413.Parsetree.pincl_loc = (copy_location pincl_loc); - Ast_413.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } -and copy_open_description : - Ast_414.Parsetree.open_description -> Ast_413.Parsetree.open_description = - fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x -and copy_open_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_414.Parsetree.open_infos -> 'g0 Ast_413.Parsetree.open_infos - = - fun f0 -> - fun - { Ast_414.Parsetree.popen_expr = popen_expr; - Ast_414.Parsetree.popen_override = popen_override; - Ast_414.Parsetree.popen_loc = popen_loc; - Ast_414.Parsetree.popen_attributes = popen_attributes } - -> - { - Ast_413.Parsetree.popen_expr = (f0 popen_expr); - Ast_413.Parsetree.popen_override = - (copy_override_flag popen_override); - Ast_413.Parsetree.popen_loc = (copy_location popen_loc); - Ast_413.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } -and copy_override_flag : - Ast_414.Asttypes.override_flag -> Ast_413.Asttypes.override_flag = - function - | Ast_414.Asttypes.Override -> Ast_413.Asttypes.Override - | Ast_414.Asttypes.Fresh -> Ast_413.Asttypes.Fresh -and copy_module_type_declaration : - Ast_414.Parsetree.module_type_declaration -> - Ast_413.Parsetree.module_type_declaration - = - fun - { Ast_414.Parsetree.pmtd_name = pmtd_name; - Ast_414.Parsetree.pmtd_type = pmtd_type; - Ast_414.Parsetree.pmtd_attributes = pmtd_attributes; - Ast_414.Parsetree.pmtd_loc = pmtd_loc } - -> - { - Ast_413.Parsetree.pmtd_name = (copy_loc (fun x -> x) pmtd_name); - Ast_413.Parsetree.pmtd_type = (Option.map copy_module_type pmtd_type); - Ast_413.Parsetree.pmtd_attributes = (copy_attributes pmtd_attributes); - Ast_413.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } -and copy_module_substitution : - Ast_414.Parsetree.module_substitution -> - Ast_413.Parsetree.module_substitution - = - fun - { Ast_414.Parsetree.pms_name = pms_name; - Ast_414.Parsetree.pms_manifest = pms_manifest; - Ast_414.Parsetree.pms_attributes = pms_attributes; - Ast_414.Parsetree.pms_loc = pms_loc } - -> - { - Ast_413.Parsetree.pms_name = (copy_loc (fun x -> x) pms_name); - Ast_413.Parsetree.pms_manifest = - (copy_loc copy_Longident_t pms_manifest); - Ast_413.Parsetree.pms_attributes = (copy_attributes pms_attributes); - Ast_413.Parsetree.pms_loc = (copy_location pms_loc) - } -and copy_module_declaration : - Ast_414.Parsetree.module_declaration -> - Ast_413.Parsetree.module_declaration - = - fun - { Ast_414.Parsetree.pmd_name = pmd_name; - Ast_414.Parsetree.pmd_type = pmd_type; - Ast_414.Parsetree.pmd_attributes = pmd_attributes; - Ast_414.Parsetree.pmd_loc = pmd_loc } - -> - { - Ast_413.Parsetree.pmd_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name); - Ast_413.Parsetree.pmd_type = (copy_module_type pmd_type); - Ast_413.Parsetree.pmd_attributes = (copy_attributes pmd_attributes); - Ast_413.Parsetree.pmd_loc = (copy_location pmd_loc) - } -and copy_type_exception : - Ast_414.Parsetree.type_exception -> Ast_413.Parsetree.type_exception = - fun - { Ast_414.Parsetree.ptyexn_constructor = ptyexn_constructor; - Ast_414.Parsetree.ptyexn_loc = ptyexn_loc; - Ast_414.Parsetree.ptyexn_attributes = ptyexn_attributes } - -> - { - Ast_413.Parsetree.ptyexn_constructor = - (copy_extension_constructor ptyexn_constructor); - Ast_413.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); - Ast_413.Parsetree.ptyexn_attributes = - (copy_attributes ptyexn_attributes) - } -and copy_type_extension : - Ast_414.Parsetree.type_extension -> Ast_413.Parsetree.type_extension = - fun - { Ast_414.Parsetree.ptyext_path = ptyext_path; - Ast_414.Parsetree.ptyext_params = ptyext_params; - Ast_414.Parsetree.ptyext_constructors = ptyext_constructors; - Ast_414.Parsetree.ptyext_private = ptyext_private; - Ast_414.Parsetree.ptyext_loc = ptyext_loc; - Ast_414.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - Ast_413.Parsetree.ptyext_path = (copy_loc copy_Longident_t ptyext_path); - Ast_413.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) ptyext_params); - Ast_413.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor ptyext_constructors); - Ast_413.Parsetree.ptyext_private = (copy_private_flag ptyext_private); - Ast_413.Parsetree.ptyext_loc = (copy_location ptyext_loc); - Ast_413.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } -and copy_extension_constructor : - Ast_414.Parsetree.extension_constructor -> - Ast_413.Parsetree.extension_constructor - = - fun - { Ast_414.Parsetree.pext_name = pext_name; - Ast_414.Parsetree.pext_kind = pext_kind; - Ast_414.Parsetree.pext_loc = pext_loc; - Ast_414.Parsetree.pext_attributes = pext_attributes } - -> - { - Ast_413.Parsetree.pext_name = (copy_loc (fun x -> x) pext_name); - Ast_413.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - Ast_413.Parsetree.pext_loc = (copy_location pext_loc); - Ast_413.Parsetree.pext_attributes = (copy_attributes pext_attributes) - } -and copy_extension_constructor_kind : - Ast_414.Parsetree.extension_constructor_kind -> - Ast_413.Parsetree.extension_constructor_kind - = - function - | Ast_414.Parsetree.Pext_decl (x0, x1, x2) -> - (match x0 with - | [] -> Ast_413.Parsetree.Pext_decl - ((copy_constructor_arguments x1), (Option.map copy_core_type x2)) - | hd :: _ -> migration_error hd.loc Extension_constructor) - | Ast_414.Parsetree.Pext_rebind x0 -> - Ast_413.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) -and copy_type_declaration : - Ast_414.Parsetree.type_declaration -> Ast_413.Parsetree.type_declaration = - fun - { Ast_414.Parsetree.ptype_name = ptype_name; - Ast_414.Parsetree.ptype_params = ptype_params; - Ast_414.Parsetree.ptype_cstrs = ptype_cstrs; - Ast_414.Parsetree.ptype_kind = ptype_kind; - Ast_414.Parsetree.ptype_private = ptype_private; - Ast_414.Parsetree.ptype_manifest = ptype_manifest; - Ast_414.Parsetree.ptype_attributes = ptype_attributes; - Ast_414.Parsetree.ptype_loc = ptype_loc } - -> - { - Ast_413.Parsetree.ptype_name = (copy_loc (fun x -> x) ptype_name); - Ast_413.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) ptype_params); - Ast_413.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0, x1, x2) = x in - ((copy_core_type x0), (copy_core_type x1), (copy_location x2))) - ptype_cstrs); - Ast_413.Parsetree.ptype_kind = (copy_type_kind ptype_kind); - Ast_413.Parsetree.ptype_private = (copy_private_flag ptype_private); - Ast_413.Parsetree.ptype_manifest = - (Option.map copy_core_type ptype_manifest); - Ast_413.Parsetree.ptype_attributes = (copy_attributes ptype_attributes); - Ast_413.Parsetree.ptype_loc = (copy_location ptype_loc) - } -and copy_private_flag : - Ast_414.Asttypes.private_flag -> Ast_413.Asttypes.private_flag = - function - | Ast_414.Asttypes.Private -> Ast_413.Asttypes.Private - | Ast_414.Asttypes.Public -> Ast_413.Asttypes.Public -and copy_type_kind : - Ast_414.Parsetree.type_kind -> Ast_413.Parsetree.type_kind = - function - | Ast_414.Parsetree.Ptype_abstract -> Ast_413.Parsetree.Ptype_abstract - | Ast_414.Parsetree.Ptype_variant x0 -> - Ast_413.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | Ast_414.Parsetree.Ptype_record x0 -> - Ast_413.Parsetree.Ptype_record (List.map copy_label_declaration x0) - | Ast_414.Parsetree.Ptype_open -> Ast_413.Parsetree.Ptype_open -and copy_constructor_declaration : - Ast_414.Parsetree.constructor_declaration -> - Ast_413.Parsetree.constructor_declaration - = - fun - { Ast_414.Parsetree.pcd_name = pcd_name; - Ast_414.Parsetree.pcd_args = pcd_args; - Ast_414.Parsetree.pcd_res = pcd_res; - Ast_414.Parsetree.pcd_loc = pcd_loc; - Ast_414.Parsetree.pcd_attributes = pcd_attributes } - -> - { - Ast_413.Parsetree.pcd_name = (copy_loc (fun x -> x) pcd_name); - Ast_413.Parsetree.pcd_args = (copy_constructor_arguments pcd_args); - Ast_413.Parsetree.pcd_res = (Option.map copy_core_type pcd_res); - Ast_413.Parsetree.pcd_loc = (copy_location pcd_loc); - Ast_413.Parsetree.pcd_attributes = (copy_attributes pcd_attributes) - } -and copy_constructor_arguments : - Ast_414.Parsetree.constructor_arguments -> - Ast_413.Parsetree.constructor_arguments - = - function - | Ast_414.Parsetree.Pcstr_tuple x0 -> - Ast_413.Parsetree.Pcstr_tuple (List.map copy_core_type x0) - | Ast_414.Parsetree.Pcstr_record x0 -> - Ast_413.Parsetree.Pcstr_record (List.map copy_label_declaration x0) -and copy_label_declaration : - Ast_414.Parsetree.label_declaration -> Ast_413.Parsetree.label_declaration - = - fun - { Ast_414.Parsetree.pld_name = pld_name; - Ast_414.Parsetree.pld_mutable = pld_mutable; - Ast_414.Parsetree.pld_type = pld_type; - Ast_414.Parsetree.pld_loc = pld_loc; - Ast_414.Parsetree.pld_attributes = pld_attributes } - -> - { - Ast_413.Parsetree.pld_name = (copy_loc (fun x -> x) pld_name); - Ast_413.Parsetree.pld_mutable = (copy_mutable_flag pld_mutable); - Ast_413.Parsetree.pld_type = (copy_core_type pld_type); - Ast_413.Parsetree.pld_loc = (copy_location pld_loc); - Ast_413.Parsetree.pld_attributes = (copy_attributes pld_attributes) - } -and copy_mutable_flag : - Ast_414.Asttypes.mutable_flag -> Ast_413.Asttypes.mutable_flag = - function - | Ast_414.Asttypes.Immutable -> Ast_413.Asttypes.Immutable - | Ast_414.Asttypes.Mutable -> Ast_413.Asttypes.Mutable -and copy_injectivity : - Ast_414.Asttypes.injectivity -> Ast_413.Asttypes.injectivity = - function - | Ast_414.Asttypes.Injective -> Ast_413.Asttypes.Injective - | Ast_414.Asttypes.NoInjectivity -> Ast_413.Asttypes.NoInjectivity -and copy_variance : Ast_414.Asttypes.variance -> Ast_413.Asttypes.variance = - function - | Ast_414.Asttypes.Covariant -> Ast_413.Asttypes.Covariant - | Ast_414.Asttypes.Contravariant -> Ast_413.Asttypes.Contravariant - | Ast_414.Asttypes.NoVariance -> Ast_413.Asttypes.NoVariance -and copy_value_description : - Ast_414.Parsetree.value_description -> Ast_413.Parsetree.value_description - = - fun - { Ast_414.Parsetree.pval_name = pval_name; - Ast_414.Parsetree.pval_type = pval_type; - Ast_414.Parsetree.pval_prim = pval_prim; - Ast_414.Parsetree.pval_attributes = pval_attributes; - Ast_414.Parsetree.pval_loc = pval_loc } - -> - { - Ast_413.Parsetree.pval_name = (copy_loc (fun x -> x) pval_name); - Ast_413.Parsetree.pval_type = (copy_core_type pval_type); - Ast_413.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - Ast_413.Parsetree.pval_attributes = (copy_attributes pval_attributes); - Ast_413.Parsetree.pval_loc = (copy_location pval_loc) - } -and copy_object_field_desc : - Ast_414.Parsetree.object_field_desc -> Ast_413.Parsetree.object_field_desc - = - function - | Ast_414.Parsetree.Otag (x0, x1) -> - Ast_413.Parsetree.Otag ((copy_loc copy_label x0), (copy_core_type x1)) - | Ast_414.Parsetree.Oinherit x0 -> - Ast_413.Parsetree.Oinherit (copy_core_type x0) -and copy_arg_label : Ast_414.Asttypes.arg_label -> Ast_413.Asttypes.arg_label - = - function - | Ast_414.Asttypes.Nolabel -> Ast_413.Asttypes.Nolabel - | Ast_414.Asttypes.Labelled x0 -> Ast_413.Asttypes.Labelled x0 - | Ast_414.Asttypes.Optional x0 -> Ast_413.Asttypes.Optional x0 -and copy_closed_flag : - Ast_414.Asttypes.closed_flag -> Ast_413.Asttypes.closed_flag = - function - | Ast_414.Asttypes.Closed -> Ast_413.Asttypes.Closed - | Ast_414.Asttypes.Open -> Ast_413.Asttypes.Open -and copy_label : Ast_414.Asttypes.label -> Ast_413.Asttypes.label = - fun x -> x -and copy_rec_flag : Ast_414.Asttypes.rec_flag -> Ast_413.Asttypes.rec_flag = - function - | Ast_414.Asttypes.Nonrecursive -> Ast_413.Asttypes.Nonrecursive - | Ast_414.Asttypes.Recursive -> Ast_413.Asttypes.Recursive -and copy_constant : Ast_414.Parsetree.constant -> Ast_413.Parsetree.constant - = - function - | Ast_414.Parsetree.Pconst_integer (x0, x1) -> - Ast_413.Parsetree.Pconst_integer (x0, (Option.map (fun x -> x) x1)) - | Ast_414.Parsetree.Pconst_char x0 -> Ast_413.Parsetree.Pconst_char x0 - | Ast_414.Parsetree.Pconst_string (x0, x1, x2) -> - Ast_413.Parsetree.Pconst_string - (x0, (copy_location x1), (Option.map (fun x -> x) x2)) - | Ast_414.Parsetree.Pconst_float (x0, x1) -> - Ast_413.Parsetree.Pconst_float (x0, (Option.map (fun x -> x) x1)) -and copy_Longident_t : Longident.t -> Longident.t = - function - | Longident.Lident x0 -> Longident.Lident x0 - | Longident.Ldot (x0, x1) -> Longident.Ldot ((copy_Longident_t x0), x1) - | Longident.Lapply (x0, x1) -> - Longident.Lapply ((copy_Longident_t x0), (copy_Longident_t x1)) -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 Ast_414.Asttypes.loc -> 'g0 Ast_413.Asttypes.loc - = - fun f0 -> - fun { Ast_414.Asttypes.txt = txt; Ast_414.Asttypes.loc = loc } -> - { - Ast_413.Asttypes.txt = (f0 txt); - Ast_413.Asttypes.loc = (copy_location loc) - } -and copy_location : Location.t -> Location.t = - fun - { Location.loc_start = loc_start; Location.loc_end = loc_end; - Location.loc_ghost = loc_ghost } - -> - { - Location.loc_start = (copy_position loc_start); - Location.loc_end = (copy_position loc_end); - Location.loc_ghost = loc_ghost - } -and copy_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum - } diff --git a/src/vendored-omp/src/migrate_parsetree_414_500.ml b/src/vendored-omp/src/migrate_parsetree_414_500.ml index 992e651b8..ab244b249 100644 --- a/src/vendored-omp/src/migrate_parsetree_414_500.ml +++ b/src/vendored-omp/src/migrate_parsetree_414_500.ml @@ -15,131 +15,3 @@ include Migrate_parsetree_414_500_migrate -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload"; - "binding_op"; "module_substitution"; "open_declaration"; "type_exception"; - "constant" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - binding_op; - module_substitution; - open_declaration; - type_exception; - constant; - (*$*) - } as mapper) -> - let module Def = Migrate_parsetree_def in - let module R = Migrate_parsetree_500_414_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> List.map copy_case (cases mapper (List.map R.copy_case x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expression (expr mapper (R.copy_expression x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pattern (pat mapper (R.copy_pattern x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_core_type (typ mapper (R.copy_core_type x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - binding_op = (fun _ x -> copy_binding_op (binding_op mapper (R.copy_binding_op x))); - module_substitution = (fun _ x -> copy_module_substitution (module_substitution mapper (R.copy_module_substitution x))); - open_declaration = (fun _ x -> copy_open_declaration (open_declaration mapper (R.copy_open_declaration x))); - type_exception = (fun _ x -> copy_type_exception (type_exception mapper (R.copy_type_exception x))); - constant = (fun _ x -> copy_constant (constant mapper (R.copy_constant x))); - (*$*) - } - - diff --git a/src/vendored-omp/src/migrate_parsetree_414_500_migrate.ml b/src/vendored-omp/src/migrate_parsetree_414_500_migrate.ml index c7f4b5902..b39f06473 100644 --- a/src/vendored-omp/src/migrate_parsetree_414_500_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_414_500_migrate.ml @@ -152,6 +152,11 @@ and copy_out_extension_constructor : (Option.map copy_out_type oext_ret_type); Ast_500.Outcometree.oext_private = (copy_private_flag oext_private) } +and copy_private_flag : + Ast_414.Asttypes.private_flag -> Ast_500.Asttypes.private_flag = + function + | Ast_414.Asttypes.Private -> Ast_500.Asttypes.Private + | Ast_414.Asttypes.Public -> Ast_500.Asttypes.Public and copy_out_rec_status : Ast_414.Outcometree.out_rec_status -> Ast_500.Outcometree.out_rec_status = function @@ -188,6 +193,16 @@ and copy_out_type_param : fun x -> let (x0, x1) = x in (x0, (let (x0, x1) = x1 in ((copy_variance x0), (copy_injectivity x1)))) +and copy_injectivity : + Ast_414.Asttypes.injectivity -> Ast_500.Asttypes.injectivity = + function + | Ast_414.Asttypes.Injective -> Ast_500.Asttypes.Injective + | Ast_414.Asttypes.NoInjectivity -> Ast_500.Asttypes.NoInjectivity +and copy_variance : Ast_414.Asttypes.variance -> Ast_500.Asttypes.variance = + function + | Ast_414.Asttypes.Covariant -> Ast_500.Asttypes.Covariant + | Ast_414.Asttypes.Contravariant -> Ast_500.Asttypes.Contravariant + | Ast_414.Asttypes.NoVariance -> Ast_500.Asttypes.NoVariance and copy_out_type : Ast_414.Outcometree.out_type -> Ast_500.Outcometree.out_type = function @@ -318,1229 +333,3 @@ and copy_out_name : Ast_414.Outcometree.out_name -> Ast_500.Outcometree.out_name = fun { Ast_414.Outcometree.printed_name = printed_name } -> { Ast_500.Outcometree.printed_name = printed_name } -and copy_toplevel_phrase : - Ast_414.Parsetree.toplevel_phrase -> Ast_500.Parsetree.toplevel_phrase = - function - | Ast_414.Parsetree.Ptop_def x0 -> - Ast_500.Parsetree.Ptop_def (copy_structure x0) - | Ast_414.Parsetree.Ptop_dir x0 -> - Ast_500.Parsetree.Ptop_dir (copy_toplevel_directive x0) -and copy_toplevel_directive : - Ast_414.Parsetree.toplevel_directive -> - Ast_500.Parsetree.toplevel_directive - = - fun - { Ast_414.Parsetree.pdir_name = pdir_name; - Ast_414.Parsetree.pdir_arg = pdir_arg; - Ast_414.Parsetree.pdir_loc = pdir_loc } - -> - { - Ast_500.Parsetree.pdir_name = (copy_loc (fun x -> x) pdir_name); - Ast_500.Parsetree.pdir_arg = - (Option.map copy_directive_argument pdir_arg); - Ast_500.Parsetree.pdir_loc = (copy_location pdir_loc) - } -and copy_directive_argument : - Ast_414.Parsetree.directive_argument -> - Ast_500.Parsetree.directive_argument - = - fun - { Ast_414.Parsetree.pdira_desc = pdira_desc; - Ast_414.Parsetree.pdira_loc = pdira_loc } - -> - { - Ast_500.Parsetree.pdira_desc = - (copy_directive_argument_desc pdira_desc); - Ast_500.Parsetree.pdira_loc = (copy_location pdira_loc) - } -and copy_directive_argument_desc : - Ast_414.Parsetree.directive_argument_desc -> - Ast_500.Parsetree.directive_argument_desc - = - function - | Ast_414.Parsetree.Pdir_string x0 -> Ast_500.Parsetree.Pdir_string x0 - | Ast_414.Parsetree.Pdir_int (x0, x1) -> - Ast_500.Parsetree.Pdir_int (x0, (Option.map (fun x -> x) x1)) - | Ast_414.Parsetree.Pdir_ident x0 -> - Ast_500.Parsetree.Pdir_ident (copy_Longident_t x0) - | Ast_414.Parsetree.Pdir_bool x0 -> Ast_500.Parsetree.Pdir_bool x0 -and copy_expression : - Ast_414.Parsetree.expression -> Ast_500.Parsetree.expression = - fun - { Ast_414.Parsetree.pexp_desc = pexp_desc; - Ast_414.Parsetree.pexp_loc = pexp_loc; - Ast_414.Parsetree.pexp_loc_stack = pexp_loc_stack; - Ast_414.Parsetree.pexp_attributes = pexp_attributes } - -> - { - Ast_500.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - Ast_500.Parsetree.pexp_loc = (copy_location pexp_loc); - Ast_500.Parsetree.pexp_loc_stack = (copy_location_stack pexp_loc_stack); - Ast_500.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } -and copy_expression_desc : - Ast_414.Parsetree.expression_desc -> Ast_500.Parsetree.expression_desc = - function - | Ast_414.Parsetree.Pexp_ident x0 -> - Ast_500.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) - | Ast_414.Parsetree.Pexp_constant x0 -> - Ast_500.Parsetree.Pexp_constant (copy_constant x0) - | Ast_414.Parsetree.Pexp_let (x0, x1, x2) -> - Ast_500.Parsetree.Pexp_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_expression x2)) - | Ast_414.Parsetree.Pexp_function x0 -> - Ast_500.Parsetree.Pexp_function (List.map copy_case x0) - | Ast_414.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_500.Parsetree.Pexp_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_expression x3)) - | Ast_414.Parsetree.Pexp_apply (x0, x1) -> - Ast_500.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_414.Parsetree.Pexp_match (x0, x1) -> - Ast_500.Parsetree.Pexp_match - ((copy_expression x0), (List.map copy_case x1)) - | Ast_414.Parsetree.Pexp_try (x0, x1) -> - Ast_500.Parsetree.Pexp_try - ((copy_expression x0), (List.map copy_case x1)) - | Ast_414.Parsetree.Pexp_tuple x0 -> - Ast_500.Parsetree.Pexp_tuple (List.map copy_expression x0) - | Ast_414.Parsetree.Pexp_construct (x0, x1) -> - Ast_500.Parsetree.Pexp_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_expression x1)) - | Ast_414.Parsetree.Pexp_variant (x0, x1) -> - Ast_500.Parsetree.Pexp_variant - ((copy_label x0), (Option.map copy_expression x1)) - | Ast_414.Parsetree.Pexp_record (x0, x1) -> - Ast_500.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_expression x1))) x0), - (Option.map copy_expression x1)) - | Ast_414.Parsetree.Pexp_field (x0, x1) -> - Ast_500.Parsetree.Pexp_field - ((copy_expression x0), (copy_loc copy_Longident_t x1)) - | Ast_414.Parsetree.Pexp_setfield (x0, x1, x2) -> - Ast_500.Parsetree.Pexp_setfield - ((copy_expression x0), (copy_loc copy_Longident_t x1), - (copy_expression x2)) - | Ast_414.Parsetree.Pexp_array x0 -> - Ast_500.Parsetree.Pexp_array (List.map copy_expression x0) - | Ast_414.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> - Ast_500.Parsetree.Pexp_ifthenelse - ((copy_expression x0), (copy_expression x1), - (Option.map copy_expression x2)) - | Ast_414.Parsetree.Pexp_sequence (x0, x1) -> - Ast_500.Parsetree.Pexp_sequence - ((copy_expression x0), (copy_expression x1)) - | Ast_414.Parsetree.Pexp_while (x0, x1) -> - Ast_500.Parsetree.Pexp_while - ((copy_expression x0), (copy_expression x1)) - | Ast_414.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> - Ast_500.Parsetree.Pexp_for - ((copy_pattern x0), (copy_expression x1), (copy_expression x2), - (copy_direction_flag x3), (copy_expression x4)) - | Ast_414.Parsetree.Pexp_constraint (x0, x1) -> - Ast_500.Parsetree.Pexp_constraint - ((copy_expression x0), (copy_core_type x1)) - | Ast_414.Parsetree.Pexp_coerce (x0, x1, x2) -> - Ast_500.Parsetree.Pexp_coerce - ((copy_expression x0), (Option.map copy_core_type x1), - (copy_core_type x2)) - | Ast_414.Parsetree.Pexp_send (x0, x1) -> - Ast_500.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc copy_label x1)) - | Ast_414.Parsetree.Pexp_new x0 -> - Ast_500.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) - | Ast_414.Parsetree.Pexp_setinstvar (x0, x1) -> - Ast_500.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), (copy_expression x1)) - | Ast_414.Parsetree.Pexp_override x0 -> - Ast_500.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_label x0), (copy_expression x1))) x0) - | Ast_414.Parsetree.Pexp_letmodule (x0, x1, x2) -> - Ast_500.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_expr x1), (copy_expression x2)) - | Ast_414.Parsetree.Pexp_letexception (x0, x1) -> - Ast_500.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), (copy_expression x1)) - | Ast_414.Parsetree.Pexp_assert x0 -> - Ast_500.Parsetree.Pexp_assert (copy_expression x0) - | Ast_414.Parsetree.Pexp_lazy x0 -> - Ast_500.Parsetree.Pexp_lazy (copy_expression x0) - | Ast_414.Parsetree.Pexp_poly (x0, x1) -> - Ast_500.Parsetree.Pexp_poly - ((copy_expression x0), (Option.map copy_core_type x1)) - | Ast_414.Parsetree.Pexp_object x0 -> - Ast_500.Parsetree.Pexp_object (copy_class_structure x0) - | Ast_414.Parsetree.Pexp_newtype (x0, x1) -> - Ast_500.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | Ast_414.Parsetree.Pexp_pack x0 -> - Ast_500.Parsetree.Pexp_pack (copy_module_expr x0) - | Ast_414.Parsetree.Pexp_open (x0, x1) -> - Ast_500.Parsetree.Pexp_open - ((copy_open_declaration x0), (copy_expression x1)) - | Ast_414.Parsetree.Pexp_letop x0 -> - Ast_500.Parsetree.Pexp_letop (copy_letop x0) - | Ast_414.Parsetree.Pexp_extension x0 -> - Ast_500.Parsetree.Pexp_extension (copy_extension x0) - | Ast_414.Parsetree.Pexp_unreachable -> Ast_500.Parsetree.Pexp_unreachable -and copy_letop : Ast_414.Parsetree.letop -> Ast_500.Parsetree.letop = - fun - { Ast_414.Parsetree.let_ = let_; Ast_414.Parsetree.ands = ands; - Ast_414.Parsetree.body = body } - -> - { - Ast_500.Parsetree.let_ = (copy_binding_op let_); - Ast_500.Parsetree.ands = (List.map copy_binding_op ands); - Ast_500.Parsetree.body = (copy_expression body) - } -and copy_binding_op : - Ast_414.Parsetree.binding_op -> Ast_500.Parsetree.binding_op = - fun - { Ast_414.Parsetree.pbop_op = pbop_op; - Ast_414.Parsetree.pbop_pat = pbop_pat; - Ast_414.Parsetree.pbop_exp = pbop_exp; - Ast_414.Parsetree.pbop_loc = pbop_loc } - -> - { - Ast_500.Parsetree.pbop_op = (copy_loc (fun x -> x) pbop_op); - Ast_500.Parsetree.pbop_pat = (copy_pattern pbop_pat); - Ast_500.Parsetree.pbop_exp = (copy_expression pbop_exp); - Ast_500.Parsetree.pbop_loc = (copy_location pbop_loc) - } -and copy_direction_flag : - Ast_414.Asttypes.direction_flag -> Ast_500.Asttypes.direction_flag = - function - | Ast_414.Asttypes.Upto -> Ast_500.Asttypes.Upto - | Ast_414.Asttypes.Downto -> Ast_500.Asttypes.Downto -and copy_case : Ast_414.Parsetree.case -> Ast_500.Parsetree.case = - fun - { Ast_414.Parsetree.pc_lhs = pc_lhs; - Ast_414.Parsetree.pc_guard = pc_guard; - Ast_414.Parsetree.pc_rhs = pc_rhs } - -> - { - Ast_500.Parsetree.pc_lhs = (copy_pattern pc_lhs); - Ast_500.Parsetree.pc_guard = (Option.map copy_expression pc_guard); - Ast_500.Parsetree.pc_rhs = (copy_expression pc_rhs) - } -and copy_value_binding : - Ast_414.Parsetree.value_binding -> Ast_500.Parsetree.value_binding = - fun - { Ast_414.Parsetree.pvb_pat = pvb_pat; - Ast_414.Parsetree.pvb_expr = pvb_expr; - Ast_414.Parsetree.pvb_attributes = pvb_attributes; - Ast_414.Parsetree.pvb_loc = pvb_loc } - -> - { - Ast_500.Parsetree.pvb_pat = (copy_pattern pvb_pat); - Ast_500.Parsetree.pvb_expr = (copy_expression pvb_expr); - Ast_500.Parsetree.pvb_attributes = (copy_attributes pvb_attributes); - Ast_500.Parsetree.pvb_loc = (copy_location pvb_loc) - } -and copy_pattern : Ast_414.Parsetree.pattern -> Ast_500.Parsetree.pattern = - fun - { Ast_414.Parsetree.ppat_desc = ppat_desc; - Ast_414.Parsetree.ppat_loc = ppat_loc; - Ast_414.Parsetree.ppat_loc_stack = ppat_loc_stack; - Ast_414.Parsetree.ppat_attributes = ppat_attributes } - -> - { - Ast_500.Parsetree.ppat_desc = (copy_pattern_desc ppat_desc); - Ast_500.Parsetree.ppat_loc = (copy_location ppat_loc); - Ast_500.Parsetree.ppat_loc_stack = (copy_location_stack ppat_loc_stack); - Ast_500.Parsetree.ppat_attributes = (copy_attributes ppat_attributes) - } -and copy_pattern_desc : - Ast_414.Parsetree.pattern_desc -> Ast_500.Parsetree.pattern_desc = - function - | Ast_414.Parsetree.Ppat_any -> Ast_500.Parsetree.Ppat_any - | Ast_414.Parsetree.Ppat_var x0 -> - Ast_500.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | Ast_414.Parsetree.Ppat_alias (x0, x1) -> - Ast_500.Parsetree.Ppat_alias - ((copy_pattern x0), (copy_loc (fun x -> x) x1)) - | Ast_414.Parsetree.Ppat_constant x0 -> - Ast_500.Parsetree.Ppat_constant (copy_constant x0) - | Ast_414.Parsetree.Ppat_interval (x0, x1) -> - Ast_500.Parsetree.Ppat_interval - ((copy_constant x0), (copy_constant x1)) - | Ast_414.Parsetree.Ppat_tuple x0 -> - Ast_500.Parsetree.Ppat_tuple (List.map copy_pattern x0) - | Ast_414.Parsetree.Ppat_construct (x0, x1) -> - Ast_500.Parsetree.Ppat_construct - ((copy_loc copy_Longident_t x0), - (Option.map - (fun x -> - let (x0, x1) = x in - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_pattern x1))) x1)) - | Ast_414.Parsetree.Ppat_variant (x0, x1) -> - Ast_500.Parsetree.Ppat_variant - ((copy_label x0), (Option.map copy_pattern x1)) - | Ast_414.Parsetree.Ppat_record (x0, x1) -> - Ast_500.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | Ast_414.Parsetree.Ppat_array x0 -> - Ast_500.Parsetree.Ppat_array (List.map copy_pattern x0) - | Ast_414.Parsetree.Ppat_or (x0, x1) -> - Ast_500.Parsetree.Ppat_or ((copy_pattern x0), (copy_pattern x1)) - | Ast_414.Parsetree.Ppat_constraint (x0, x1) -> - Ast_500.Parsetree.Ppat_constraint - ((copy_pattern x0), (copy_core_type x1)) - | Ast_414.Parsetree.Ppat_type x0 -> - Ast_500.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) - | Ast_414.Parsetree.Ppat_lazy x0 -> - Ast_500.Parsetree.Ppat_lazy (copy_pattern x0) - | Ast_414.Parsetree.Ppat_unpack x0 -> - Ast_500.Parsetree.Ppat_unpack - (copy_loc (fun x -> Option.map (fun x -> x) x) x0) - | Ast_414.Parsetree.Ppat_exception x0 -> - Ast_500.Parsetree.Ppat_exception (copy_pattern x0) - | Ast_414.Parsetree.Ppat_extension x0 -> - Ast_500.Parsetree.Ppat_extension (copy_extension x0) - | Ast_414.Parsetree.Ppat_open (x0, x1) -> - Ast_500.Parsetree.Ppat_open - ((copy_loc copy_Longident_t x0), (copy_pattern x1)) -and copy_core_type : - Ast_414.Parsetree.core_type -> Ast_500.Parsetree.core_type = - fun - { Ast_414.Parsetree.ptyp_desc = ptyp_desc; - Ast_414.Parsetree.ptyp_loc = ptyp_loc; - Ast_414.Parsetree.ptyp_loc_stack = ptyp_loc_stack; - Ast_414.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - Ast_500.Parsetree.ptyp_desc = (copy_core_type_desc ptyp_desc); - Ast_500.Parsetree.ptyp_loc = (copy_location ptyp_loc); - Ast_500.Parsetree.ptyp_loc_stack = (copy_location_stack ptyp_loc_stack); - Ast_500.Parsetree.ptyp_attributes = (copy_attributes ptyp_attributes) - } -and copy_location_stack : - Ast_414.Parsetree.location_stack -> Ast_500.Parsetree.location_stack = - fun x -> List.map copy_location x -and copy_core_type_desc : - Ast_414.Parsetree.core_type_desc -> Ast_500.Parsetree.core_type_desc = - function - | Ast_414.Parsetree.Ptyp_any -> Ast_500.Parsetree.Ptyp_any - | Ast_414.Parsetree.Ptyp_var x0 -> Ast_500.Parsetree.Ptyp_var x0 - | Ast_414.Parsetree.Ptyp_arrow (x0, x1, x2) -> - Ast_500.Parsetree.Ptyp_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_core_type x2)) - | Ast_414.Parsetree.Ptyp_tuple x0 -> - Ast_500.Parsetree.Ptyp_tuple (List.map copy_core_type x0) - | Ast_414.Parsetree.Ptyp_constr (x0, x1) -> - Ast_500.Parsetree.Ptyp_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_414.Parsetree.Ptyp_object (x0, x1) -> - Ast_500.Parsetree.Ptyp_object - ((List.map copy_object_field x0), (copy_closed_flag x1)) - | Ast_414.Parsetree.Ptyp_class (x0, x1) -> - Ast_500.Parsetree.Ptyp_class - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_414.Parsetree.Ptyp_alias (x0, x1) -> - Ast_500.Parsetree.Ptyp_alias ((copy_core_type x0), x1) - | Ast_414.Parsetree.Ptyp_variant (x0, x1, x2) -> - Ast_500.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), (copy_closed_flag x1), - (Option.map (fun x -> List.map copy_label x) x2)) - | Ast_414.Parsetree.Ptyp_poly (x0, x1) -> - Ast_500.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | Ast_414.Parsetree.Ptyp_package x0 -> - Ast_500.Parsetree.Ptyp_package (copy_package_type x0) - | Ast_414.Parsetree.Ptyp_extension x0 -> - Ast_500.Parsetree.Ptyp_extension (copy_extension x0) -and copy_package_type : - Ast_414.Parsetree.package_type -> Ast_500.Parsetree.package_type = - fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_core_type x1))) x1)) -and copy_row_field : - Ast_414.Parsetree.row_field -> Ast_500.Parsetree.row_field = - fun - { Ast_414.Parsetree.prf_desc = prf_desc; - Ast_414.Parsetree.prf_loc = prf_loc; - Ast_414.Parsetree.prf_attributes = prf_attributes } - -> - { - Ast_500.Parsetree.prf_desc = (copy_row_field_desc prf_desc); - Ast_500.Parsetree.prf_loc = (copy_location prf_loc); - Ast_500.Parsetree.prf_attributes = (copy_attributes prf_attributes) - } -and copy_row_field_desc : - Ast_414.Parsetree.row_field_desc -> Ast_500.Parsetree.row_field_desc = - function - | Ast_414.Parsetree.Rtag (x0, x1, x2) -> - Ast_500.Parsetree.Rtag - ((copy_loc copy_label x0), x1, (List.map copy_core_type x2)) - | Ast_414.Parsetree.Rinherit x0 -> - Ast_500.Parsetree.Rinherit (copy_core_type x0) -and copy_object_field : - Ast_414.Parsetree.object_field -> Ast_500.Parsetree.object_field = - fun - { Ast_414.Parsetree.pof_desc = pof_desc; - Ast_414.Parsetree.pof_loc = pof_loc; - Ast_414.Parsetree.pof_attributes = pof_attributes } - -> - { - Ast_500.Parsetree.pof_desc = (copy_object_field_desc pof_desc); - Ast_500.Parsetree.pof_loc = (copy_location pof_loc); - Ast_500.Parsetree.pof_attributes = (copy_attributes pof_attributes) - } -and copy_attributes : - Ast_414.Parsetree.attributes -> Ast_500.Parsetree.attributes = - fun x -> List.map copy_attribute x -and copy_attribute : - Ast_414.Parsetree.attribute -> Ast_500.Parsetree.attribute = - fun - { Ast_414.Parsetree.attr_name = attr_name; - Ast_414.Parsetree.attr_payload = attr_payload; - Ast_414.Parsetree.attr_loc = attr_loc } - -> - { - Ast_500.Parsetree.attr_name = (copy_loc (fun x -> x) attr_name); - Ast_500.Parsetree.attr_payload = (copy_payload attr_payload); - Ast_500.Parsetree.attr_loc = (copy_location attr_loc) - } -and copy_payload : Ast_414.Parsetree.payload -> Ast_500.Parsetree.payload = - function - | Ast_414.Parsetree.PStr x0 -> Ast_500.Parsetree.PStr (copy_structure x0) - | Ast_414.Parsetree.PSig x0 -> Ast_500.Parsetree.PSig (copy_signature x0) - | Ast_414.Parsetree.PTyp x0 -> Ast_500.Parsetree.PTyp (copy_core_type x0) - | Ast_414.Parsetree.PPat (x0, x1) -> - Ast_500.Parsetree.PPat - ((copy_pattern x0), (Option.map copy_expression x1)) -and copy_structure : - Ast_414.Parsetree.structure -> Ast_500.Parsetree.structure = - fun x -> List.map copy_structure_item x -and copy_structure_item : - Ast_414.Parsetree.structure_item -> Ast_500.Parsetree.structure_item = - fun - { Ast_414.Parsetree.pstr_desc = pstr_desc; - Ast_414.Parsetree.pstr_loc = pstr_loc } - -> - { - Ast_500.Parsetree.pstr_desc = (copy_structure_item_desc pstr_desc); - Ast_500.Parsetree.pstr_loc = (copy_location pstr_loc) - } -and copy_structure_item_desc : - Ast_414.Parsetree.structure_item_desc -> - Ast_500.Parsetree.structure_item_desc - = - function - | Ast_414.Parsetree.Pstr_eval (x0, x1) -> - Ast_500.Parsetree.Pstr_eval - ((copy_expression x0), (copy_attributes x1)) - | Ast_414.Parsetree.Pstr_value (x0, x1) -> - Ast_500.Parsetree.Pstr_value - ((copy_rec_flag x0), (List.map copy_value_binding x1)) - | Ast_414.Parsetree.Pstr_primitive x0 -> - Ast_500.Parsetree.Pstr_primitive (copy_value_description x0) - | Ast_414.Parsetree.Pstr_type (x0, x1) -> - Ast_500.Parsetree.Pstr_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_414.Parsetree.Pstr_typext x0 -> - Ast_500.Parsetree.Pstr_typext (copy_type_extension x0) - | Ast_414.Parsetree.Pstr_exception x0 -> - Ast_500.Parsetree.Pstr_exception (copy_type_exception x0) - | Ast_414.Parsetree.Pstr_module x0 -> - Ast_500.Parsetree.Pstr_module (copy_module_binding x0) - | Ast_414.Parsetree.Pstr_recmodule x0 -> - Ast_500.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) - | Ast_414.Parsetree.Pstr_modtype x0 -> - Ast_500.Parsetree.Pstr_modtype (copy_module_type_declaration x0) - | Ast_414.Parsetree.Pstr_open x0 -> - Ast_500.Parsetree.Pstr_open (copy_open_declaration x0) - | Ast_414.Parsetree.Pstr_class x0 -> - Ast_500.Parsetree.Pstr_class (List.map copy_class_declaration x0) - | Ast_414.Parsetree.Pstr_class_type x0 -> - Ast_500.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | Ast_414.Parsetree.Pstr_include x0 -> - Ast_500.Parsetree.Pstr_include (copy_include_declaration x0) - | Ast_414.Parsetree.Pstr_attribute x0 -> - Ast_500.Parsetree.Pstr_attribute (copy_attribute x0) - | Ast_414.Parsetree.Pstr_extension (x0, x1) -> - Ast_500.Parsetree.Pstr_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_include_declaration : - Ast_414.Parsetree.include_declaration -> - Ast_500.Parsetree.include_declaration - = fun x -> copy_include_infos copy_module_expr x -and copy_class_declaration : - Ast_414.Parsetree.class_declaration -> Ast_500.Parsetree.class_declaration - = fun x -> copy_class_infos copy_class_expr x -and copy_class_expr : - Ast_414.Parsetree.class_expr -> Ast_500.Parsetree.class_expr = - fun - { Ast_414.Parsetree.pcl_desc = pcl_desc; - Ast_414.Parsetree.pcl_loc = pcl_loc; - Ast_414.Parsetree.pcl_attributes = pcl_attributes } - -> - { - Ast_500.Parsetree.pcl_desc = (copy_class_expr_desc pcl_desc); - Ast_500.Parsetree.pcl_loc = (copy_location pcl_loc); - Ast_500.Parsetree.pcl_attributes = (copy_attributes pcl_attributes) - } -and copy_class_expr_desc : - Ast_414.Parsetree.class_expr_desc -> Ast_500.Parsetree.class_expr_desc = - function - | Ast_414.Parsetree.Pcl_constr (x0, x1) -> - Ast_500.Parsetree.Pcl_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_414.Parsetree.Pcl_structure x0 -> - Ast_500.Parsetree.Pcl_structure (copy_class_structure x0) - | Ast_414.Parsetree.Pcl_fun (x0, x1, x2, x3) -> - Ast_500.Parsetree.Pcl_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_class_expr x3)) - | Ast_414.Parsetree.Pcl_apply (x0, x1) -> - Ast_500.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_414.Parsetree.Pcl_let (x0, x1, x2) -> - Ast_500.Parsetree.Pcl_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_class_expr x2)) - | Ast_414.Parsetree.Pcl_constraint (x0, x1) -> - Ast_500.Parsetree.Pcl_constraint - ((copy_class_expr x0), (copy_class_type x1)) - | Ast_414.Parsetree.Pcl_extension x0 -> - Ast_500.Parsetree.Pcl_extension (copy_extension x0) - | Ast_414.Parsetree.Pcl_open (x0, x1) -> - Ast_500.Parsetree.Pcl_open - ((copy_open_description x0), (copy_class_expr x1)) -and copy_class_structure : - Ast_414.Parsetree.class_structure -> Ast_500.Parsetree.class_structure = - fun - { Ast_414.Parsetree.pcstr_self = pcstr_self; - Ast_414.Parsetree.pcstr_fields = pcstr_fields } - -> - { - Ast_500.Parsetree.pcstr_self = (copy_pattern pcstr_self); - Ast_500.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } -and copy_class_field : - Ast_414.Parsetree.class_field -> Ast_500.Parsetree.class_field = - fun - { Ast_414.Parsetree.pcf_desc = pcf_desc; - Ast_414.Parsetree.pcf_loc = pcf_loc; - Ast_414.Parsetree.pcf_attributes = pcf_attributes } - -> - { - Ast_500.Parsetree.pcf_desc = (copy_class_field_desc pcf_desc); - Ast_500.Parsetree.pcf_loc = (copy_location pcf_loc); - Ast_500.Parsetree.pcf_attributes = (copy_attributes pcf_attributes) - } -and copy_class_field_desc : - Ast_414.Parsetree.class_field_desc -> Ast_500.Parsetree.class_field_desc = - function - | Ast_414.Parsetree.Pcf_inherit (x0, x1, x2) -> - Ast_500.Parsetree.Pcf_inherit - ((copy_override_flag x0), (copy_class_expr x1), - (Option.map (fun x -> copy_loc (fun x -> x) x) x2)) - | Ast_414.Parsetree.Pcf_val x0 -> - Ast_500.Parsetree.Pcf_val - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | Ast_414.Parsetree.Pcf_method x0 -> - Ast_500.Parsetree.Pcf_method - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_class_field_kind x2))) - | Ast_414.Parsetree.Pcf_constraint x0 -> - Ast_500.Parsetree.Pcf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_414.Parsetree.Pcf_initializer x0 -> - Ast_500.Parsetree.Pcf_initializer (copy_expression x0) - | Ast_414.Parsetree.Pcf_attribute x0 -> - Ast_500.Parsetree.Pcf_attribute (copy_attribute x0) - | Ast_414.Parsetree.Pcf_extension x0 -> - Ast_500.Parsetree.Pcf_extension (copy_extension x0) -and copy_class_field_kind : - Ast_414.Parsetree.class_field_kind -> Ast_500.Parsetree.class_field_kind = - function - | Ast_414.Parsetree.Cfk_virtual x0 -> - Ast_500.Parsetree.Cfk_virtual (copy_core_type x0) - | Ast_414.Parsetree.Cfk_concrete (x0, x1) -> - Ast_500.Parsetree.Cfk_concrete - ((copy_override_flag x0), (copy_expression x1)) -and copy_open_declaration : - Ast_414.Parsetree.open_declaration -> Ast_500.Parsetree.open_declaration = - fun x -> copy_open_infos copy_module_expr x -and copy_module_binding : - Ast_414.Parsetree.module_binding -> Ast_500.Parsetree.module_binding = - fun - { Ast_414.Parsetree.pmb_name = pmb_name; - Ast_414.Parsetree.pmb_expr = pmb_expr; - Ast_414.Parsetree.pmb_attributes = pmb_attributes; - Ast_414.Parsetree.pmb_loc = pmb_loc } - -> - { - Ast_500.Parsetree.pmb_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name); - Ast_500.Parsetree.pmb_expr = (copy_module_expr pmb_expr); - Ast_500.Parsetree.pmb_attributes = (copy_attributes pmb_attributes); - Ast_500.Parsetree.pmb_loc = (copy_location pmb_loc) - } -and copy_module_expr : - Ast_414.Parsetree.module_expr -> Ast_500.Parsetree.module_expr = - fun - { Ast_414.Parsetree.pmod_desc = pmod_desc; - Ast_414.Parsetree.pmod_loc = pmod_loc; - Ast_414.Parsetree.pmod_attributes = pmod_attributes } - -> - { - Ast_500.Parsetree.pmod_desc = (copy_module_expr_desc pmod_desc); - Ast_500.Parsetree.pmod_loc = (copy_location pmod_loc); - Ast_500.Parsetree.pmod_attributes = (copy_attributes pmod_attributes) - } -and copy_module_expr_desc : - Ast_414.Parsetree.module_expr_desc -> Ast_500.Parsetree.module_expr_desc = - function - | Ast_414.Parsetree.Pmod_ident x0 -> - Ast_500.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) - | Ast_414.Parsetree.Pmod_structure x0 -> - Ast_500.Parsetree.Pmod_structure (copy_structure x0) - | Ast_414.Parsetree.Pmod_functor (x0, x1) -> - Ast_500.Parsetree.Pmod_functor - ((copy_functor_parameter x0), (copy_module_expr x1)) - | Ast_414.Parsetree.Pmod_apply (x0, x1) -> - Ast_500.Parsetree.Pmod_apply - ((copy_module_expr x0), (copy_module_expr x1)) - | Ast_414.Parsetree.Pmod_constraint (x0, x1) -> - Ast_500.Parsetree.Pmod_constraint - ((copy_module_expr x0), (copy_module_type x1)) - | Ast_414.Parsetree.Pmod_unpack x0 -> - Ast_500.Parsetree.Pmod_unpack (copy_expression x0) - | Ast_414.Parsetree.Pmod_extension x0 -> - Ast_500.Parsetree.Pmod_extension (copy_extension x0) -and copy_functor_parameter : - Ast_414.Parsetree.functor_parameter -> Ast_500.Parsetree.functor_parameter - = - function - | Ast_414.Parsetree.Unit -> Ast_500.Parsetree.Unit - | Ast_414.Parsetree.Named (x0, x1) -> - Ast_500.Parsetree.Named - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_type x1)) -and copy_module_type : - Ast_414.Parsetree.module_type -> Ast_500.Parsetree.module_type = - fun - { Ast_414.Parsetree.pmty_desc = pmty_desc; - Ast_414.Parsetree.pmty_loc = pmty_loc; - Ast_414.Parsetree.pmty_attributes = pmty_attributes } - -> - { - Ast_500.Parsetree.pmty_desc = (copy_module_type_desc pmty_desc); - Ast_500.Parsetree.pmty_loc = (copy_location pmty_loc); - Ast_500.Parsetree.pmty_attributes = (copy_attributes pmty_attributes) - } -and copy_module_type_desc : - Ast_414.Parsetree.module_type_desc -> Ast_500.Parsetree.module_type_desc = - function - | Ast_414.Parsetree.Pmty_ident x0 -> - Ast_500.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) - | Ast_414.Parsetree.Pmty_signature x0 -> - Ast_500.Parsetree.Pmty_signature (copy_signature x0) - | Ast_414.Parsetree.Pmty_functor (x0, x1) -> - Ast_500.Parsetree.Pmty_functor - ((copy_functor_parameter x0), (copy_module_type x1)) - | Ast_414.Parsetree.Pmty_with (x0, x1) -> - Ast_500.Parsetree.Pmty_with - ((copy_module_type x0), (List.map copy_with_constraint x1)) - | Ast_414.Parsetree.Pmty_typeof x0 -> - Ast_500.Parsetree.Pmty_typeof (copy_module_expr x0) - | Ast_414.Parsetree.Pmty_extension x0 -> - Ast_500.Parsetree.Pmty_extension (copy_extension x0) - | Ast_414.Parsetree.Pmty_alias x0 -> - Ast_500.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) -and copy_with_constraint : - Ast_414.Parsetree.with_constraint -> Ast_500.Parsetree.with_constraint = - function - | Ast_414.Parsetree.Pwith_type (x0, x1) -> - Ast_500.Parsetree.Pwith_type - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_414.Parsetree.Pwith_module (x0, x1) -> - Ast_500.Parsetree.Pwith_module - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) - | Ast_414.Parsetree.Pwith_modtype (x0, x1) -> - Ast_500.Parsetree.Pwith_modtype - ((copy_loc copy_Longident_t x0), (copy_module_type x1)) - | Ast_414.Parsetree.Pwith_modtypesubst (x0, x1) -> - Ast_500.Parsetree.Pwith_modtypesubst - ((copy_loc copy_Longident_t x0), (copy_module_type x1)) - | Ast_414.Parsetree.Pwith_typesubst (x0, x1) -> - Ast_500.Parsetree.Pwith_typesubst - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_414.Parsetree.Pwith_modsubst (x0, x1) -> - Ast_500.Parsetree.Pwith_modsubst - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) -and copy_signature : - Ast_414.Parsetree.signature -> Ast_500.Parsetree.signature = - fun x -> List.map copy_signature_item x -and copy_signature_item : - Ast_414.Parsetree.signature_item -> Ast_500.Parsetree.signature_item = - fun - { Ast_414.Parsetree.psig_desc = psig_desc; - Ast_414.Parsetree.psig_loc = psig_loc } - -> - { - Ast_500.Parsetree.psig_desc = (copy_signature_item_desc psig_desc); - Ast_500.Parsetree.psig_loc = (copy_location psig_loc) - } -and copy_signature_item_desc : - Ast_414.Parsetree.signature_item_desc -> - Ast_500.Parsetree.signature_item_desc - = - function - | Ast_414.Parsetree.Psig_value x0 -> - Ast_500.Parsetree.Psig_value (copy_value_description x0) - | Ast_414.Parsetree.Psig_type (x0, x1) -> - Ast_500.Parsetree.Psig_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_414.Parsetree.Psig_typesubst x0 -> - Ast_500.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) - | Ast_414.Parsetree.Psig_typext x0 -> - Ast_500.Parsetree.Psig_typext (copy_type_extension x0) - | Ast_414.Parsetree.Psig_exception x0 -> - Ast_500.Parsetree.Psig_exception (copy_type_exception x0) - | Ast_414.Parsetree.Psig_module x0 -> - Ast_500.Parsetree.Psig_module (copy_module_declaration x0) - | Ast_414.Parsetree.Psig_modsubst x0 -> - Ast_500.Parsetree.Psig_modsubst (copy_module_substitution x0) - | Ast_414.Parsetree.Psig_recmodule x0 -> - Ast_500.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) - | Ast_414.Parsetree.Psig_modtype x0 -> - Ast_500.Parsetree.Psig_modtype (copy_module_type_declaration x0) - | Ast_414.Parsetree.Psig_modtypesubst x0 -> - Ast_500.Parsetree.Psig_modtypesubst (copy_module_type_declaration x0) - | Ast_414.Parsetree.Psig_open x0 -> - Ast_500.Parsetree.Psig_open (copy_open_description x0) - | Ast_414.Parsetree.Psig_include x0 -> - Ast_500.Parsetree.Psig_include (copy_include_description x0) - | Ast_414.Parsetree.Psig_class x0 -> - Ast_500.Parsetree.Psig_class (List.map copy_class_description x0) - | Ast_414.Parsetree.Psig_class_type x0 -> - Ast_500.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | Ast_414.Parsetree.Psig_attribute x0 -> - Ast_500.Parsetree.Psig_attribute (copy_attribute x0) - | Ast_414.Parsetree.Psig_extension (x0, x1) -> - Ast_500.Parsetree.Psig_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_class_type_declaration : - Ast_414.Parsetree.class_type_declaration -> - Ast_500.Parsetree.class_type_declaration - = fun x -> copy_class_infos copy_class_type x -and copy_class_description : - Ast_414.Parsetree.class_description -> Ast_500.Parsetree.class_description - = fun x -> copy_class_infos copy_class_type x -and copy_class_type : - Ast_414.Parsetree.class_type -> Ast_500.Parsetree.class_type = - fun - { Ast_414.Parsetree.pcty_desc = pcty_desc; - Ast_414.Parsetree.pcty_loc = pcty_loc; - Ast_414.Parsetree.pcty_attributes = pcty_attributes } - -> - { - Ast_500.Parsetree.pcty_desc = (copy_class_type_desc pcty_desc); - Ast_500.Parsetree.pcty_loc = (copy_location pcty_loc); - Ast_500.Parsetree.pcty_attributes = (copy_attributes pcty_attributes) - } -and copy_class_type_desc : - Ast_414.Parsetree.class_type_desc -> Ast_500.Parsetree.class_type_desc = - function - | Ast_414.Parsetree.Pcty_constr (x0, x1) -> - Ast_500.Parsetree.Pcty_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_414.Parsetree.Pcty_signature x0 -> - Ast_500.Parsetree.Pcty_signature (copy_class_signature x0) - | Ast_414.Parsetree.Pcty_arrow (x0, x1, x2) -> - Ast_500.Parsetree.Pcty_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_class_type x2)) - | Ast_414.Parsetree.Pcty_extension x0 -> - Ast_500.Parsetree.Pcty_extension (copy_extension x0) - | Ast_414.Parsetree.Pcty_open (x0, x1) -> - Ast_500.Parsetree.Pcty_open - ((copy_open_description x0), (copy_class_type x1)) -and copy_class_signature : - Ast_414.Parsetree.class_signature -> Ast_500.Parsetree.class_signature = - fun - { Ast_414.Parsetree.pcsig_self = pcsig_self; - Ast_414.Parsetree.pcsig_fields = pcsig_fields } - -> - { - Ast_500.Parsetree.pcsig_self = (copy_core_type pcsig_self); - Ast_500.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } -and copy_class_type_field : - Ast_414.Parsetree.class_type_field -> Ast_500.Parsetree.class_type_field = - fun - { Ast_414.Parsetree.pctf_desc = pctf_desc; - Ast_414.Parsetree.pctf_loc = pctf_loc; - Ast_414.Parsetree.pctf_attributes = pctf_attributes } - -> - { - Ast_500.Parsetree.pctf_desc = (copy_class_type_field_desc pctf_desc); - Ast_500.Parsetree.pctf_loc = (copy_location pctf_loc); - Ast_500.Parsetree.pctf_attributes = (copy_attributes pctf_attributes) - } -and copy_class_type_field_desc : - Ast_414.Parsetree.class_type_field_desc -> - Ast_500.Parsetree.class_type_field_desc - = - function - | Ast_414.Parsetree.Pctf_inherit x0 -> - Ast_500.Parsetree.Pctf_inherit (copy_class_type x0) - | Ast_414.Parsetree.Pctf_val x0 -> - Ast_500.Parsetree.Pctf_val - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_414.Parsetree.Pctf_method x0 -> - Ast_500.Parsetree.Pctf_method - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_414.Parsetree.Pctf_constraint x0 -> - Ast_500.Parsetree.Pctf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_414.Parsetree.Pctf_attribute x0 -> - Ast_500.Parsetree.Pctf_attribute (copy_attribute x0) - | Ast_414.Parsetree.Pctf_extension x0 -> - Ast_500.Parsetree.Pctf_extension (copy_extension x0) -and copy_extension : - Ast_414.Parsetree.extension -> Ast_500.Parsetree.extension = - fun x -> - let (x0, x1) = x in ((copy_loc (fun x -> x) x0), (copy_payload x1)) -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_414.Parsetree.class_infos -> 'g0 Ast_500.Parsetree.class_infos - = - fun f0 -> - fun - { Ast_414.Parsetree.pci_virt = pci_virt; - Ast_414.Parsetree.pci_params = pci_params; - Ast_414.Parsetree.pci_name = pci_name; - Ast_414.Parsetree.pci_expr = pci_expr; - Ast_414.Parsetree.pci_loc = pci_loc; - Ast_414.Parsetree.pci_attributes = pci_attributes } - -> - { - Ast_500.Parsetree.pci_virt = (copy_virtual_flag pci_virt); - Ast_500.Parsetree.pci_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) pci_params); - Ast_500.Parsetree.pci_name = (copy_loc (fun x -> x) pci_name); - Ast_500.Parsetree.pci_expr = (f0 pci_expr); - Ast_500.Parsetree.pci_loc = (copy_location pci_loc); - Ast_500.Parsetree.pci_attributes = (copy_attributes pci_attributes) - } -and copy_virtual_flag : - Ast_414.Asttypes.virtual_flag -> Ast_500.Asttypes.virtual_flag = - function - | Ast_414.Asttypes.Virtual -> Ast_500.Asttypes.Virtual - | Ast_414.Asttypes.Concrete -> Ast_500.Asttypes.Concrete -and copy_include_description : - Ast_414.Parsetree.include_description -> - Ast_500.Parsetree.include_description - = fun x -> copy_include_infos copy_module_type x -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_414.Parsetree.include_infos -> - 'g0 Ast_500.Parsetree.include_infos - = - fun f0 -> - fun - { Ast_414.Parsetree.pincl_mod = pincl_mod; - Ast_414.Parsetree.pincl_loc = pincl_loc; - Ast_414.Parsetree.pincl_attributes = pincl_attributes } - -> - { - Ast_500.Parsetree.pincl_mod = (f0 pincl_mod); - Ast_500.Parsetree.pincl_loc = (copy_location pincl_loc); - Ast_500.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } -and copy_open_description : - Ast_414.Parsetree.open_description -> Ast_500.Parsetree.open_description = - fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x -and copy_open_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_414.Parsetree.open_infos -> 'g0 Ast_500.Parsetree.open_infos - = - fun f0 -> - fun - { Ast_414.Parsetree.popen_expr = popen_expr; - Ast_414.Parsetree.popen_override = popen_override; - Ast_414.Parsetree.popen_loc = popen_loc; - Ast_414.Parsetree.popen_attributes = popen_attributes } - -> - { - Ast_500.Parsetree.popen_expr = (f0 popen_expr); - Ast_500.Parsetree.popen_override = - (copy_override_flag popen_override); - Ast_500.Parsetree.popen_loc = (copy_location popen_loc); - Ast_500.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } -and copy_override_flag : - Ast_414.Asttypes.override_flag -> Ast_500.Asttypes.override_flag = - function - | Ast_414.Asttypes.Override -> Ast_500.Asttypes.Override - | Ast_414.Asttypes.Fresh -> Ast_500.Asttypes.Fresh -and copy_module_type_declaration : - Ast_414.Parsetree.module_type_declaration -> - Ast_500.Parsetree.module_type_declaration - = - fun - { Ast_414.Parsetree.pmtd_name = pmtd_name; - Ast_414.Parsetree.pmtd_type = pmtd_type; - Ast_414.Parsetree.pmtd_attributes = pmtd_attributes; - Ast_414.Parsetree.pmtd_loc = pmtd_loc } - -> - { - Ast_500.Parsetree.pmtd_name = (copy_loc (fun x -> x) pmtd_name); - Ast_500.Parsetree.pmtd_type = (Option.map copy_module_type pmtd_type); - Ast_500.Parsetree.pmtd_attributes = (copy_attributes pmtd_attributes); - Ast_500.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } -and copy_module_substitution : - Ast_414.Parsetree.module_substitution -> - Ast_500.Parsetree.module_substitution - = - fun - { Ast_414.Parsetree.pms_name = pms_name; - Ast_414.Parsetree.pms_manifest = pms_manifest; - Ast_414.Parsetree.pms_attributes = pms_attributes; - Ast_414.Parsetree.pms_loc = pms_loc } - -> - { - Ast_500.Parsetree.pms_name = (copy_loc (fun x -> x) pms_name); - Ast_500.Parsetree.pms_manifest = - (copy_loc copy_Longident_t pms_manifest); - Ast_500.Parsetree.pms_attributes = (copy_attributes pms_attributes); - Ast_500.Parsetree.pms_loc = (copy_location pms_loc) - } -and copy_module_declaration : - Ast_414.Parsetree.module_declaration -> - Ast_500.Parsetree.module_declaration - = - fun - { Ast_414.Parsetree.pmd_name = pmd_name; - Ast_414.Parsetree.pmd_type = pmd_type; - Ast_414.Parsetree.pmd_attributes = pmd_attributes; - Ast_414.Parsetree.pmd_loc = pmd_loc } - -> - { - Ast_500.Parsetree.pmd_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name); - Ast_500.Parsetree.pmd_type = (copy_module_type pmd_type); - Ast_500.Parsetree.pmd_attributes = (copy_attributes pmd_attributes); - Ast_500.Parsetree.pmd_loc = (copy_location pmd_loc) - } -and copy_type_exception : - Ast_414.Parsetree.type_exception -> Ast_500.Parsetree.type_exception = - fun - { Ast_414.Parsetree.ptyexn_constructor = ptyexn_constructor; - Ast_414.Parsetree.ptyexn_loc = ptyexn_loc; - Ast_414.Parsetree.ptyexn_attributes = ptyexn_attributes } - -> - { - Ast_500.Parsetree.ptyexn_constructor = - (copy_extension_constructor ptyexn_constructor); - Ast_500.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); - Ast_500.Parsetree.ptyexn_attributes = - (copy_attributes ptyexn_attributes) - } -and copy_type_extension : - Ast_414.Parsetree.type_extension -> Ast_500.Parsetree.type_extension = - fun - { Ast_414.Parsetree.ptyext_path = ptyext_path; - Ast_414.Parsetree.ptyext_params = ptyext_params; - Ast_414.Parsetree.ptyext_constructors = ptyext_constructors; - Ast_414.Parsetree.ptyext_private = ptyext_private; - Ast_414.Parsetree.ptyext_loc = ptyext_loc; - Ast_414.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - Ast_500.Parsetree.ptyext_path = (copy_loc copy_Longident_t ptyext_path); - Ast_500.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) ptyext_params); - Ast_500.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor ptyext_constructors); - Ast_500.Parsetree.ptyext_private = (copy_private_flag ptyext_private); - Ast_500.Parsetree.ptyext_loc = (copy_location ptyext_loc); - Ast_500.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } -and copy_extension_constructor : - Ast_414.Parsetree.extension_constructor -> - Ast_500.Parsetree.extension_constructor - = - fun - { Ast_414.Parsetree.pext_name = pext_name; - Ast_414.Parsetree.pext_kind = pext_kind; - Ast_414.Parsetree.pext_loc = pext_loc; - Ast_414.Parsetree.pext_attributes = pext_attributes } - -> - { - Ast_500.Parsetree.pext_name = (copy_loc (fun x -> x) pext_name); - Ast_500.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - Ast_500.Parsetree.pext_loc = (copy_location pext_loc); - Ast_500.Parsetree.pext_attributes = (copy_attributes pext_attributes) - } -and copy_extension_constructor_kind : - Ast_414.Parsetree.extension_constructor_kind -> - Ast_500.Parsetree.extension_constructor_kind - = - function - | Ast_414.Parsetree.Pext_decl (x0, x1, x2) -> - Ast_500.Parsetree.Pext_decl - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_constructor_arguments x1), (Option.map copy_core_type x2)) - | Ast_414.Parsetree.Pext_rebind x0 -> - Ast_500.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) -and copy_type_declaration : - Ast_414.Parsetree.type_declaration -> Ast_500.Parsetree.type_declaration = - fun - { Ast_414.Parsetree.ptype_name = ptype_name; - Ast_414.Parsetree.ptype_params = ptype_params; - Ast_414.Parsetree.ptype_cstrs = ptype_cstrs; - Ast_414.Parsetree.ptype_kind = ptype_kind; - Ast_414.Parsetree.ptype_private = ptype_private; - Ast_414.Parsetree.ptype_manifest = ptype_manifest; - Ast_414.Parsetree.ptype_attributes = ptype_attributes; - Ast_414.Parsetree.ptype_loc = ptype_loc } - -> - { - Ast_500.Parsetree.ptype_name = (copy_loc (fun x -> x) ptype_name); - Ast_500.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) ptype_params); - Ast_500.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0, x1, x2) = x in - ((copy_core_type x0), (copy_core_type x1), (copy_location x2))) - ptype_cstrs); - Ast_500.Parsetree.ptype_kind = (copy_type_kind ptype_kind); - Ast_500.Parsetree.ptype_private = (copy_private_flag ptype_private); - Ast_500.Parsetree.ptype_manifest = - (Option.map copy_core_type ptype_manifest); - Ast_500.Parsetree.ptype_attributes = (copy_attributes ptype_attributes); - Ast_500.Parsetree.ptype_loc = (copy_location ptype_loc) - } -and copy_private_flag : - Ast_414.Asttypes.private_flag -> Ast_500.Asttypes.private_flag = - function - | Ast_414.Asttypes.Private -> Ast_500.Asttypes.Private - | Ast_414.Asttypes.Public -> Ast_500.Asttypes.Public -and copy_type_kind : - Ast_414.Parsetree.type_kind -> Ast_500.Parsetree.type_kind = - function - | Ast_414.Parsetree.Ptype_abstract -> Ast_500.Parsetree.Ptype_abstract - | Ast_414.Parsetree.Ptype_variant x0 -> - Ast_500.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | Ast_414.Parsetree.Ptype_record x0 -> - Ast_500.Parsetree.Ptype_record (List.map copy_label_declaration x0) - | Ast_414.Parsetree.Ptype_open -> Ast_500.Parsetree.Ptype_open -and copy_constructor_declaration : - Ast_414.Parsetree.constructor_declaration -> - Ast_500.Parsetree.constructor_declaration - = - fun - { Ast_414.Parsetree.pcd_name = pcd_name; - Ast_414.Parsetree.pcd_vars = pcd_vars; - Ast_414.Parsetree.pcd_args = pcd_args; - Ast_414.Parsetree.pcd_res = pcd_res; - Ast_414.Parsetree.pcd_loc = pcd_loc; - Ast_414.Parsetree.pcd_attributes = pcd_attributes } - -> - { - Ast_500.Parsetree.pcd_name = (copy_loc (fun x -> x) pcd_name); - Ast_500.Parsetree.pcd_vars = - (List.map (fun x -> copy_loc (fun x -> x) x) pcd_vars); - Ast_500.Parsetree.pcd_args = (copy_constructor_arguments pcd_args); - Ast_500.Parsetree.pcd_res = (Option.map copy_core_type pcd_res); - Ast_500.Parsetree.pcd_loc = (copy_location pcd_loc); - Ast_500.Parsetree.pcd_attributes = (copy_attributes pcd_attributes) - } -and copy_constructor_arguments : - Ast_414.Parsetree.constructor_arguments -> - Ast_500.Parsetree.constructor_arguments - = - function - | Ast_414.Parsetree.Pcstr_tuple x0 -> - Ast_500.Parsetree.Pcstr_tuple (List.map copy_core_type x0) - | Ast_414.Parsetree.Pcstr_record x0 -> - Ast_500.Parsetree.Pcstr_record (List.map copy_label_declaration x0) -and copy_label_declaration : - Ast_414.Parsetree.label_declaration -> Ast_500.Parsetree.label_declaration - = - fun - { Ast_414.Parsetree.pld_name = pld_name; - Ast_414.Parsetree.pld_mutable = pld_mutable; - Ast_414.Parsetree.pld_type = pld_type; - Ast_414.Parsetree.pld_loc = pld_loc; - Ast_414.Parsetree.pld_attributes = pld_attributes } - -> - { - Ast_500.Parsetree.pld_name = (copy_loc (fun x -> x) pld_name); - Ast_500.Parsetree.pld_mutable = (copy_mutable_flag pld_mutable); - Ast_500.Parsetree.pld_type = (copy_core_type pld_type); - Ast_500.Parsetree.pld_loc = (copy_location pld_loc); - Ast_500.Parsetree.pld_attributes = (copy_attributes pld_attributes) - } -and copy_mutable_flag : - Ast_414.Asttypes.mutable_flag -> Ast_500.Asttypes.mutable_flag = - function - | Ast_414.Asttypes.Immutable -> Ast_500.Asttypes.Immutable - | Ast_414.Asttypes.Mutable -> Ast_500.Asttypes.Mutable -and copy_injectivity : - Ast_414.Asttypes.injectivity -> Ast_500.Asttypes.injectivity = - function - | Ast_414.Asttypes.Injective -> Ast_500.Asttypes.Injective - | Ast_414.Asttypes.NoInjectivity -> Ast_500.Asttypes.NoInjectivity -and copy_variance : Ast_414.Asttypes.variance -> Ast_500.Asttypes.variance = - function - | Ast_414.Asttypes.Covariant -> Ast_500.Asttypes.Covariant - | Ast_414.Asttypes.Contravariant -> Ast_500.Asttypes.Contravariant - | Ast_414.Asttypes.NoVariance -> Ast_500.Asttypes.NoVariance -and copy_value_description : - Ast_414.Parsetree.value_description -> Ast_500.Parsetree.value_description - = - fun - { Ast_414.Parsetree.pval_name = pval_name; - Ast_414.Parsetree.pval_type = pval_type; - Ast_414.Parsetree.pval_prim = pval_prim; - Ast_414.Parsetree.pval_attributes = pval_attributes; - Ast_414.Parsetree.pval_loc = pval_loc } - -> - { - Ast_500.Parsetree.pval_name = (copy_loc (fun x -> x) pval_name); - Ast_500.Parsetree.pval_type = (copy_core_type pval_type); - Ast_500.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - Ast_500.Parsetree.pval_attributes = (copy_attributes pval_attributes); - Ast_500.Parsetree.pval_loc = (copy_location pval_loc) - } -and copy_object_field_desc : - Ast_414.Parsetree.object_field_desc -> Ast_500.Parsetree.object_field_desc - = - function - | Ast_414.Parsetree.Otag (x0, x1) -> - Ast_500.Parsetree.Otag ((copy_loc copy_label x0), (copy_core_type x1)) - | Ast_414.Parsetree.Oinherit x0 -> - Ast_500.Parsetree.Oinherit (copy_core_type x0) -and copy_arg_label : Ast_414.Asttypes.arg_label -> Ast_500.Asttypes.arg_label - = - function - | Ast_414.Asttypes.Nolabel -> Ast_500.Asttypes.Nolabel - | Ast_414.Asttypes.Labelled x0 -> Ast_500.Asttypes.Labelled x0 - | Ast_414.Asttypes.Optional x0 -> Ast_500.Asttypes.Optional x0 -and copy_closed_flag : - Ast_414.Asttypes.closed_flag -> Ast_500.Asttypes.closed_flag = - function - | Ast_414.Asttypes.Closed -> Ast_500.Asttypes.Closed - | Ast_414.Asttypes.Open -> Ast_500.Asttypes.Open -and copy_label : Ast_414.Asttypes.label -> Ast_500.Asttypes.label = - fun x -> x -and copy_rec_flag : Ast_414.Asttypes.rec_flag -> Ast_500.Asttypes.rec_flag = - function - | Ast_414.Asttypes.Nonrecursive -> Ast_500.Asttypes.Nonrecursive - | Ast_414.Asttypes.Recursive -> Ast_500.Asttypes.Recursive -and copy_constant : Ast_414.Parsetree.constant -> Ast_500.Parsetree.constant - = - function - | Ast_414.Parsetree.Pconst_integer (x0, x1) -> - Ast_500.Parsetree.Pconst_integer (x0, (Option.map (fun x -> x) x1)) - | Ast_414.Parsetree.Pconst_char x0 -> Ast_500.Parsetree.Pconst_char x0 - | Ast_414.Parsetree.Pconst_string (x0, x1, x2) -> - Ast_500.Parsetree.Pconst_string - (x0, (copy_location x1), (Option.map (fun x -> x) x2)) - | Ast_414.Parsetree.Pconst_float (x0, x1) -> - Ast_500.Parsetree.Pconst_float (x0, (Option.map (fun x -> x) x1)) -and copy_Longident_t : Longident.t -> Longident.t = - function - | Longident.Lident x0 -> Longident.Lident x0 - | Longident.Ldot (x0, x1) -> Longident.Ldot ((copy_Longident_t x0), x1) - | Longident.Lapply (x0, x1) -> - Longident.Lapply ((copy_Longident_t x0), (copy_Longident_t x1)) -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 Ast_414.Asttypes.loc -> 'g0 Ast_500.Asttypes.loc - = - fun f0 -> - fun { Ast_414.Asttypes.txt = txt; Ast_414.Asttypes.loc = loc } -> - { - Ast_500.Asttypes.txt = (f0 txt); - Ast_500.Asttypes.loc = (copy_location loc) - } -and copy_location : Location.t -> Location.t = - fun - { Location.loc_start = loc_start; Location.loc_end = loc_end; - Location.loc_ghost = loc_ghost } - -> - { - Location.loc_start = (copy_position loc_start); - Location.loc_end = (copy_position loc_end); - Location.loc_ghost = loc_ghost - } -and copy_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum - } diff --git a/src/vendored-omp/src/migrate_parsetree_500_414.ml b/src/vendored-omp/src/migrate_parsetree_500_414.ml index 5cf09bc0a..3023b5a13 100644 --- a/src/vendored-omp/src/migrate_parsetree_500_414.ml +++ b/src/vendored-omp/src/migrate_parsetree_500_414.ml @@ -14,131 +14,3 @@ (**************************************************************************) include Migrate_parsetree_500_414_migrate - -(*$ open Printf - let fields = [ - "attribute"; "attributes"; "case"; "cases"; "class_declaration"; - "class_description"; "class_expr"; "class_field"; "class_signature"; - "class_structure"; "class_type"; "class_type_declaration"; - "class_type_field"; "constructor_declaration"; "expr"; "extension"; - "extension_constructor"; "include_declaration"; "include_description"; - "label_declaration"; "location"; "module_binding"; "module_declaration"; - "module_expr"; "module_type"; "module_type_declaration"; - "open_description"; "pat"; "signature"; "signature_item"; "structure"; - "structure_item"; "typ"; "type_declaration"; "type_extension"; - "type_kind"; "value_binding"; "value_description"; - "with_constraint"; "payload"; - "binding_op"; "module_substitution"; "open_declaration"; "type_exception"; - "constant" - ] - let foreach_field f = - printf "\n"; - List.iter f fields -*)(*$*) - -let copy_mapper = fun - ({ From.Ast_mapper. - (*$ foreach_field (printf "%s;\n")*) - attribute; - attributes; - case; - cases; - class_declaration; - class_description; - class_expr; - class_field; - class_signature; - class_structure; - class_type; - class_type_declaration; - class_type_field; - constructor_declaration; - expr; - extension; - extension_constructor; - include_declaration; - include_description; - label_declaration; - location; - module_binding; - module_declaration; - module_expr; - module_type; - module_type_declaration; - open_description; - pat; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_extension; - type_kind; - value_binding; - value_description; - with_constraint; - payload; - binding_op; - module_substitution; - open_declaration; - type_exception; - constant; - (*$*) - } as mapper) -> - - let module Def = Migrate_parsetree_def in - let module R = Migrate_parsetree_414_500_migrate in - { - To.Ast_mapper. - (*$ foreach_field (fun s -> - printf - "%s = (fun _ x -> copy_%s (%s mapper (R.copy_%s x)));\n" s s s s) - *) - attribute = (fun _ x -> copy_attribute (attribute mapper (R.copy_attribute x))); - attributes = (fun _ x -> copy_attributes (attributes mapper (R.copy_attributes x))); - case = (fun _ x -> copy_case (case mapper (R.copy_case x))); - cases = (fun _ x -> List.map copy_case (cases mapper (List.map R.copy_case x))); - class_declaration = (fun _ x -> copy_class_declaration (class_declaration mapper (R.copy_class_declaration x))); - class_description = (fun _ x -> copy_class_description (class_description mapper (R.copy_class_description x))); - class_expr = (fun _ x -> copy_class_expr (class_expr mapper (R.copy_class_expr x))); - class_field = (fun _ x -> copy_class_field (class_field mapper (R.copy_class_field x))); - class_signature = (fun _ x -> copy_class_signature (class_signature mapper (R.copy_class_signature x))); - class_structure = (fun _ x -> copy_class_structure (class_structure mapper (R.copy_class_structure x))); - class_type = (fun _ x -> copy_class_type (class_type mapper (R.copy_class_type x))); - class_type_declaration = (fun _ x -> copy_class_type_declaration (class_type_declaration mapper (R.copy_class_type_declaration x))); - class_type_field = (fun _ x -> copy_class_type_field (class_type_field mapper (R.copy_class_type_field x))); - constructor_declaration = (fun _ x -> copy_constructor_declaration (constructor_declaration mapper (R.copy_constructor_declaration x))); - expr = (fun _ x -> copy_expression (expr mapper (R.copy_expression x))); - extension = (fun _ x -> copy_extension (extension mapper (R.copy_extension x))); - extension_constructor = (fun _ x -> copy_extension_constructor (extension_constructor mapper (R.copy_extension_constructor x))); - include_declaration = (fun _ x -> copy_include_declaration (include_declaration mapper (R.copy_include_declaration x))); - include_description = (fun _ x -> copy_include_description (include_description mapper (R.copy_include_description x))); - label_declaration = (fun _ x -> copy_label_declaration (label_declaration mapper (R.copy_label_declaration x))); - location = (fun _ x -> copy_location (location mapper (R.copy_location x))); - module_binding = (fun _ x -> copy_module_binding (module_binding mapper (R.copy_module_binding x))); - module_declaration = (fun _ x -> copy_module_declaration (module_declaration mapper (R.copy_module_declaration x))); - module_expr = (fun _ x -> copy_module_expr (module_expr mapper (R.copy_module_expr x))); - module_type = (fun _ x -> copy_module_type (module_type mapper (R.copy_module_type x))); - module_type_declaration = (fun _ x -> copy_module_type_declaration (module_type_declaration mapper (R.copy_module_type_declaration x))); - open_description = (fun _ x -> copy_open_description (open_description mapper (R.copy_open_description x))); - pat = (fun _ x -> copy_pattern (pat mapper (R.copy_pattern x))); - signature = (fun _ x -> copy_signature (signature mapper (R.copy_signature x))); - signature_item = (fun _ x -> copy_signature_item (signature_item mapper (R.copy_signature_item x))); - structure = (fun _ x -> copy_structure (structure mapper (R.copy_structure x))); - structure_item = (fun _ x -> copy_structure_item (structure_item mapper (R.copy_structure_item x))); - typ = (fun _ x -> copy_core_type (typ mapper (R.copy_core_type x))); - type_declaration = (fun _ x -> copy_type_declaration (type_declaration mapper (R.copy_type_declaration x))); - type_extension = (fun _ x -> copy_type_extension (type_extension mapper (R.copy_type_extension x))); - type_kind = (fun _ x -> copy_type_kind (type_kind mapper (R.copy_type_kind x))); - value_binding = (fun _ x -> copy_value_binding (value_binding mapper (R.copy_value_binding x))); - value_description = (fun _ x -> copy_value_description (value_description mapper (R.copy_value_description x))); - with_constraint = (fun _ x -> copy_with_constraint (with_constraint mapper (R.copy_with_constraint x))); - payload = (fun _ x -> copy_payload (payload mapper (R.copy_payload x))); - binding_op = (fun _ x -> copy_binding_op (binding_op mapper (R.copy_binding_op x))); - module_substitution = (fun _ x -> copy_module_substitution (module_substitution mapper (R.copy_module_substitution x))); - open_declaration = (fun _ x -> copy_open_declaration (open_declaration mapper (R.copy_open_declaration x))); - type_exception = (fun _ x -> copy_type_exception (type_exception mapper (R.copy_type_exception x))); - constant = (fun _ x -> copy_constant (constant mapper (R.copy_constant x))); - (*$*) - } diff --git a/src/vendored-omp/src/migrate_parsetree_500_414_migrate.ml b/src/vendored-omp/src/migrate_parsetree_500_414_migrate.ml index b8722778f..f78548d43 100644 --- a/src/vendored-omp/src/migrate_parsetree_500_414_migrate.ml +++ b/src/vendored-omp/src/migrate_parsetree_500_414_migrate.ml @@ -152,6 +152,11 @@ and copy_out_extension_constructor : (Option.map copy_out_type oext_ret_type); Ast_414.Outcometree.oext_private = (copy_private_flag oext_private) } +and copy_private_flag : + Ast_500.Asttypes.private_flag -> Ast_414.Asttypes.private_flag = + function + | Ast_500.Asttypes.Private -> Ast_414.Asttypes.Private + | Ast_500.Asttypes.Public -> Ast_414.Asttypes.Public and copy_out_rec_status : Ast_500.Outcometree.out_rec_status -> Ast_414.Outcometree.out_rec_status = function @@ -188,6 +193,16 @@ and copy_out_type_param : fun x -> let (x0, x1) = x in (x0, (let (x0, x1) = x1 in ((copy_variance x0), (copy_injectivity x1)))) +and copy_injectivity : + Ast_500.Asttypes.injectivity -> Ast_414.Asttypes.injectivity = + function + | Ast_500.Asttypes.Injective -> Ast_414.Asttypes.Injective + | Ast_500.Asttypes.NoInjectivity -> Ast_414.Asttypes.NoInjectivity +and copy_variance : Ast_500.Asttypes.variance -> Ast_414.Asttypes.variance = + function + | Ast_500.Asttypes.Covariant -> Ast_414.Asttypes.Covariant + | Ast_500.Asttypes.Contravariant -> Ast_414.Asttypes.Contravariant + | Ast_500.Asttypes.NoVariance -> Ast_414.Asttypes.NoVariance and copy_out_type : Ast_500.Outcometree.out_type -> Ast_414.Outcometree.out_type = function @@ -318,1229 +333,3 @@ and copy_out_name : Ast_500.Outcometree.out_name -> Ast_414.Outcometree.out_name = fun { Ast_500.Outcometree.printed_name = printed_name } -> { Ast_414.Outcometree.printed_name = printed_name } -and copy_toplevel_phrase : - Ast_500.Parsetree.toplevel_phrase -> Ast_414.Parsetree.toplevel_phrase = - function - | Ast_500.Parsetree.Ptop_def x0 -> - Ast_414.Parsetree.Ptop_def (copy_structure x0) - | Ast_500.Parsetree.Ptop_dir x0 -> - Ast_414.Parsetree.Ptop_dir (copy_toplevel_directive x0) -and copy_toplevel_directive : - Ast_500.Parsetree.toplevel_directive -> - Ast_414.Parsetree.toplevel_directive - = - fun - { Ast_500.Parsetree.pdir_name = pdir_name; - Ast_500.Parsetree.pdir_arg = pdir_arg; - Ast_500.Parsetree.pdir_loc = pdir_loc } - -> - { - Ast_414.Parsetree.pdir_name = (copy_loc (fun x -> x) pdir_name); - Ast_414.Parsetree.pdir_arg = - (Option.map copy_directive_argument pdir_arg); - Ast_414.Parsetree.pdir_loc = (copy_location pdir_loc) - } -and copy_directive_argument : - Ast_500.Parsetree.directive_argument -> - Ast_414.Parsetree.directive_argument - = - fun - { Ast_500.Parsetree.pdira_desc = pdira_desc; - Ast_500.Parsetree.pdira_loc = pdira_loc } - -> - { - Ast_414.Parsetree.pdira_desc = - (copy_directive_argument_desc pdira_desc); - Ast_414.Parsetree.pdira_loc = (copy_location pdira_loc) - } -and copy_directive_argument_desc : - Ast_500.Parsetree.directive_argument_desc -> - Ast_414.Parsetree.directive_argument_desc - = - function - | Ast_500.Parsetree.Pdir_string x0 -> Ast_414.Parsetree.Pdir_string x0 - | Ast_500.Parsetree.Pdir_int (x0, x1) -> - Ast_414.Parsetree.Pdir_int (x0, (Option.map (fun x -> x) x1)) - | Ast_500.Parsetree.Pdir_ident x0 -> - Ast_414.Parsetree.Pdir_ident (copy_Longident_t x0) - | Ast_500.Parsetree.Pdir_bool x0 -> Ast_414.Parsetree.Pdir_bool x0 -and copy_expression : - Ast_500.Parsetree.expression -> Ast_414.Parsetree.expression = - fun - { Ast_500.Parsetree.pexp_desc = pexp_desc; - Ast_500.Parsetree.pexp_loc = pexp_loc; - Ast_500.Parsetree.pexp_loc_stack = pexp_loc_stack; - Ast_500.Parsetree.pexp_attributes = pexp_attributes } - -> - { - Ast_414.Parsetree.pexp_desc = (copy_expression_desc pexp_desc); - Ast_414.Parsetree.pexp_loc = (copy_location pexp_loc); - Ast_414.Parsetree.pexp_loc_stack = (copy_location_stack pexp_loc_stack); - Ast_414.Parsetree.pexp_attributes = (copy_attributes pexp_attributes) - } -and copy_expression_desc : - Ast_500.Parsetree.expression_desc -> Ast_414.Parsetree.expression_desc = - function - | Ast_500.Parsetree.Pexp_ident x0 -> - Ast_414.Parsetree.Pexp_ident (copy_loc copy_Longident_t x0) - | Ast_500.Parsetree.Pexp_constant x0 -> - Ast_414.Parsetree.Pexp_constant (copy_constant x0) - | Ast_500.Parsetree.Pexp_let (x0, x1, x2) -> - Ast_414.Parsetree.Pexp_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_expression x2)) - | Ast_500.Parsetree.Pexp_function x0 -> - Ast_414.Parsetree.Pexp_function (List.map copy_case x0) - | Ast_500.Parsetree.Pexp_fun (x0, x1, x2, x3) -> - Ast_414.Parsetree.Pexp_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_expression x3)) - | Ast_500.Parsetree.Pexp_apply (x0, x1) -> - Ast_414.Parsetree.Pexp_apply - ((copy_expression x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_500.Parsetree.Pexp_match (x0, x1) -> - Ast_414.Parsetree.Pexp_match - ((copy_expression x0), (List.map copy_case x1)) - | Ast_500.Parsetree.Pexp_try (x0, x1) -> - Ast_414.Parsetree.Pexp_try - ((copy_expression x0), (List.map copy_case x1)) - | Ast_500.Parsetree.Pexp_tuple x0 -> - Ast_414.Parsetree.Pexp_tuple (List.map copy_expression x0) - | Ast_500.Parsetree.Pexp_construct (x0, x1) -> - Ast_414.Parsetree.Pexp_construct - ((copy_loc copy_Longident_t x0), (Option.map copy_expression x1)) - | Ast_500.Parsetree.Pexp_variant (x0, x1) -> - Ast_414.Parsetree.Pexp_variant - ((copy_label x0), (Option.map copy_expression x1)) - | Ast_500.Parsetree.Pexp_record (x0, x1) -> - Ast_414.Parsetree.Pexp_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_expression x1))) x0), - (Option.map copy_expression x1)) - | Ast_500.Parsetree.Pexp_field (x0, x1) -> - Ast_414.Parsetree.Pexp_field - ((copy_expression x0), (copy_loc copy_Longident_t x1)) - | Ast_500.Parsetree.Pexp_setfield (x0, x1, x2) -> - Ast_414.Parsetree.Pexp_setfield - ((copy_expression x0), (copy_loc copy_Longident_t x1), - (copy_expression x2)) - | Ast_500.Parsetree.Pexp_array x0 -> - Ast_414.Parsetree.Pexp_array (List.map copy_expression x0) - | Ast_500.Parsetree.Pexp_ifthenelse (x0, x1, x2) -> - Ast_414.Parsetree.Pexp_ifthenelse - ((copy_expression x0), (copy_expression x1), - (Option.map copy_expression x2)) - | Ast_500.Parsetree.Pexp_sequence (x0, x1) -> - Ast_414.Parsetree.Pexp_sequence - ((copy_expression x0), (copy_expression x1)) - | Ast_500.Parsetree.Pexp_while (x0, x1) -> - Ast_414.Parsetree.Pexp_while - ((copy_expression x0), (copy_expression x1)) - | Ast_500.Parsetree.Pexp_for (x0, x1, x2, x3, x4) -> - Ast_414.Parsetree.Pexp_for - ((copy_pattern x0), (copy_expression x1), (copy_expression x2), - (copy_direction_flag x3), (copy_expression x4)) - | Ast_500.Parsetree.Pexp_constraint (x0, x1) -> - Ast_414.Parsetree.Pexp_constraint - ((copy_expression x0), (copy_core_type x1)) - | Ast_500.Parsetree.Pexp_coerce (x0, x1, x2) -> - Ast_414.Parsetree.Pexp_coerce - ((copy_expression x0), (Option.map copy_core_type x1), - (copy_core_type x2)) - | Ast_500.Parsetree.Pexp_send (x0, x1) -> - Ast_414.Parsetree.Pexp_send - ((copy_expression x0), (copy_loc copy_label x1)) - | Ast_500.Parsetree.Pexp_new x0 -> - Ast_414.Parsetree.Pexp_new (copy_loc copy_Longident_t x0) - | Ast_500.Parsetree.Pexp_setinstvar (x0, x1) -> - Ast_414.Parsetree.Pexp_setinstvar - ((copy_loc copy_label x0), (copy_expression x1)) - | Ast_500.Parsetree.Pexp_override x0 -> - Ast_414.Parsetree.Pexp_override - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_label x0), (copy_expression x1))) x0) - | Ast_500.Parsetree.Pexp_letmodule (x0, x1, x2) -> - Ast_414.Parsetree.Pexp_letmodule - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_expr x1), (copy_expression x2)) - | Ast_500.Parsetree.Pexp_letexception (x0, x1) -> - Ast_414.Parsetree.Pexp_letexception - ((copy_extension_constructor x0), (copy_expression x1)) - | Ast_500.Parsetree.Pexp_assert x0 -> - Ast_414.Parsetree.Pexp_assert (copy_expression x0) - | Ast_500.Parsetree.Pexp_lazy x0 -> - Ast_414.Parsetree.Pexp_lazy (copy_expression x0) - | Ast_500.Parsetree.Pexp_poly (x0, x1) -> - Ast_414.Parsetree.Pexp_poly - ((copy_expression x0), (Option.map copy_core_type x1)) - | Ast_500.Parsetree.Pexp_object x0 -> - Ast_414.Parsetree.Pexp_object (copy_class_structure x0) - | Ast_500.Parsetree.Pexp_newtype (x0, x1) -> - Ast_414.Parsetree.Pexp_newtype - ((copy_loc (fun x -> x) x0), (copy_expression x1)) - | Ast_500.Parsetree.Pexp_pack x0 -> - Ast_414.Parsetree.Pexp_pack (copy_module_expr x0) - | Ast_500.Parsetree.Pexp_open (x0, x1) -> - Ast_414.Parsetree.Pexp_open - ((copy_open_declaration x0), (copy_expression x1)) - | Ast_500.Parsetree.Pexp_letop x0 -> - Ast_414.Parsetree.Pexp_letop (copy_letop x0) - | Ast_500.Parsetree.Pexp_extension x0 -> - Ast_414.Parsetree.Pexp_extension (copy_extension x0) - | Ast_500.Parsetree.Pexp_unreachable -> Ast_414.Parsetree.Pexp_unreachable -and copy_letop : Ast_500.Parsetree.letop -> Ast_414.Parsetree.letop = - fun - { Ast_500.Parsetree.let_ = let_; Ast_500.Parsetree.ands = ands; - Ast_500.Parsetree.body = body } - -> - { - Ast_414.Parsetree.let_ = (copy_binding_op let_); - Ast_414.Parsetree.ands = (List.map copy_binding_op ands); - Ast_414.Parsetree.body = (copy_expression body) - } -and copy_binding_op : - Ast_500.Parsetree.binding_op -> Ast_414.Parsetree.binding_op = - fun - { Ast_500.Parsetree.pbop_op = pbop_op; - Ast_500.Parsetree.pbop_pat = pbop_pat; - Ast_500.Parsetree.pbop_exp = pbop_exp; - Ast_500.Parsetree.pbop_loc = pbop_loc } - -> - { - Ast_414.Parsetree.pbop_op = (copy_loc (fun x -> x) pbop_op); - Ast_414.Parsetree.pbop_pat = (copy_pattern pbop_pat); - Ast_414.Parsetree.pbop_exp = (copy_expression pbop_exp); - Ast_414.Parsetree.pbop_loc = (copy_location pbop_loc) - } -and copy_direction_flag : - Ast_500.Asttypes.direction_flag -> Ast_414.Asttypes.direction_flag = - function - | Ast_500.Asttypes.Upto -> Ast_414.Asttypes.Upto - | Ast_500.Asttypes.Downto -> Ast_414.Asttypes.Downto -and copy_case : Ast_500.Parsetree.case -> Ast_414.Parsetree.case = - fun - { Ast_500.Parsetree.pc_lhs = pc_lhs; - Ast_500.Parsetree.pc_guard = pc_guard; - Ast_500.Parsetree.pc_rhs = pc_rhs } - -> - { - Ast_414.Parsetree.pc_lhs = (copy_pattern pc_lhs); - Ast_414.Parsetree.pc_guard = (Option.map copy_expression pc_guard); - Ast_414.Parsetree.pc_rhs = (copy_expression pc_rhs) - } -and copy_value_binding : - Ast_500.Parsetree.value_binding -> Ast_414.Parsetree.value_binding = - fun - { Ast_500.Parsetree.pvb_pat = pvb_pat; - Ast_500.Parsetree.pvb_expr = pvb_expr; - Ast_500.Parsetree.pvb_attributes = pvb_attributes; - Ast_500.Parsetree.pvb_loc = pvb_loc } - -> - { - Ast_414.Parsetree.pvb_pat = (copy_pattern pvb_pat); - Ast_414.Parsetree.pvb_expr = (copy_expression pvb_expr); - Ast_414.Parsetree.pvb_attributes = (copy_attributes pvb_attributes); - Ast_414.Parsetree.pvb_loc = (copy_location pvb_loc) - } -and copy_pattern : Ast_500.Parsetree.pattern -> Ast_414.Parsetree.pattern = - fun - { Ast_500.Parsetree.ppat_desc = ppat_desc; - Ast_500.Parsetree.ppat_loc = ppat_loc; - Ast_500.Parsetree.ppat_loc_stack = ppat_loc_stack; - Ast_500.Parsetree.ppat_attributes = ppat_attributes } - -> - { - Ast_414.Parsetree.ppat_desc = (copy_pattern_desc ppat_desc); - Ast_414.Parsetree.ppat_loc = (copy_location ppat_loc); - Ast_414.Parsetree.ppat_loc_stack = (copy_location_stack ppat_loc_stack); - Ast_414.Parsetree.ppat_attributes = (copy_attributes ppat_attributes) - } -and copy_pattern_desc : - Ast_500.Parsetree.pattern_desc -> Ast_414.Parsetree.pattern_desc = - function - | Ast_500.Parsetree.Ppat_any -> Ast_414.Parsetree.Ppat_any - | Ast_500.Parsetree.Ppat_var x0 -> - Ast_414.Parsetree.Ppat_var (copy_loc (fun x -> x) x0) - | Ast_500.Parsetree.Ppat_alias (x0, x1) -> - Ast_414.Parsetree.Ppat_alias - ((copy_pattern x0), (copy_loc (fun x -> x) x1)) - | Ast_500.Parsetree.Ppat_constant x0 -> - Ast_414.Parsetree.Ppat_constant (copy_constant x0) - | Ast_500.Parsetree.Ppat_interval (x0, x1) -> - Ast_414.Parsetree.Ppat_interval - ((copy_constant x0), (copy_constant x1)) - | Ast_500.Parsetree.Ppat_tuple x0 -> - Ast_414.Parsetree.Ppat_tuple (List.map copy_pattern x0) - | Ast_500.Parsetree.Ppat_construct (x0, x1) -> - Ast_414.Parsetree.Ppat_construct - ((copy_loc copy_Longident_t x0), - (Option.map - (fun x -> - let (x0, x1) = x in - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_pattern x1))) x1)) - | Ast_500.Parsetree.Ppat_variant (x0, x1) -> - Ast_414.Parsetree.Ppat_variant - ((copy_label x0), (Option.map copy_pattern x1)) - | Ast_500.Parsetree.Ppat_record (x0, x1) -> - Ast_414.Parsetree.Ppat_record - ((List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_pattern x1))) x0), - (copy_closed_flag x1)) - | Ast_500.Parsetree.Ppat_array x0 -> - Ast_414.Parsetree.Ppat_array (List.map copy_pattern x0) - | Ast_500.Parsetree.Ppat_or (x0, x1) -> - Ast_414.Parsetree.Ppat_or ((copy_pattern x0), (copy_pattern x1)) - | Ast_500.Parsetree.Ppat_constraint (x0, x1) -> - Ast_414.Parsetree.Ppat_constraint - ((copy_pattern x0), (copy_core_type x1)) - | Ast_500.Parsetree.Ppat_type x0 -> - Ast_414.Parsetree.Ppat_type (copy_loc copy_Longident_t x0) - | Ast_500.Parsetree.Ppat_lazy x0 -> - Ast_414.Parsetree.Ppat_lazy (copy_pattern x0) - | Ast_500.Parsetree.Ppat_unpack x0 -> - Ast_414.Parsetree.Ppat_unpack - (copy_loc (fun x -> Option.map (fun x -> x) x) x0) - | Ast_500.Parsetree.Ppat_exception x0 -> - Ast_414.Parsetree.Ppat_exception (copy_pattern x0) - | Ast_500.Parsetree.Ppat_extension x0 -> - Ast_414.Parsetree.Ppat_extension (copy_extension x0) - | Ast_500.Parsetree.Ppat_open (x0, x1) -> - Ast_414.Parsetree.Ppat_open - ((copy_loc copy_Longident_t x0), (copy_pattern x1)) -and copy_core_type : - Ast_500.Parsetree.core_type -> Ast_414.Parsetree.core_type = - fun - { Ast_500.Parsetree.ptyp_desc = ptyp_desc; - Ast_500.Parsetree.ptyp_loc = ptyp_loc; - Ast_500.Parsetree.ptyp_loc_stack = ptyp_loc_stack; - Ast_500.Parsetree.ptyp_attributes = ptyp_attributes } - -> - { - Ast_414.Parsetree.ptyp_desc = (copy_core_type_desc ptyp_desc); - Ast_414.Parsetree.ptyp_loc = (copy_location ptyp_loc); - Ast_414.Parsetree.ptyp_loc_stack = (copy_location_stack ptyp_loc_stack); - Ast_414.Parsetree.ptyp_attributes = (copy_attributes ptyp_attributes) - } -and copy_location_stack : - Ast_500.Parsetree.location_stack -> Ast_414.Parsetree.location_stack = - fun x -> List.map copy_location x -and copy_core_type_desc : - Ast_500.Parsetree.core_type_desc -> Ast_414.Parsetree.core_type_desc = - function - | Ast_500.Parsetree.Ptyp_any -> Ast_414.Parsetree.Ptyp_any - | Ast_500.Parsetree.Ptyp_var x0 -> Ast_414.Parsetree.Ptyp_var x0 - | Ast_500.Parsetree.Ptyp_arrow (x0, x1, x2) -> - Ast_414.Parsetree.Ptyp_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_core_type x2)) - | Ast_500.Parsetree.Ptyp_tuple x0 -> - Ast_414.Parsetree.Ptyp_tuple (List.map copy_core_type x0) - | Ast_500.Parsetree.Ptyp_constr (x0, x1) -> - Ast_414.Parsetree.Ptyp_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_500.Parsetree.Ptyp_object (x0, x1) -> - Ast_414.Parsetree.Ptyp_object - ((List.map copy_object_field x0), (copy_closed_flag x1)) - | Ast_500.Parsetree.Ptyp_class (x0, x1) -> - Ast_414.Parsetree.Ptyp_class - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_500.Parsetree.Ptyp_alias (x0, x1) -> - Ast_414.Parsetree.Ptyp_alias ((copy_core_type x0), x1) - | Ast_500.Parsetree.Ptyp_variant (x0, x1, x2) -> - Ast_414.Parsetree.Ptyp_variant - ((List.map copy_row_field x0), (copy_closed_flag x1), - (Option.map (fun x -> List.map copy_label x) x2)) - | Ast_500.Parsetree.Ptyp_poly (x0, x1) -> - Ast_414.Parsetree.Ptyp_poly - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_core_type x1)) - | Ast_500.Parsetree.Ptyp_package x0 -> - Ast_414.Parsetree.Ptyp_package (copy_package_type x0) - | Ast_500.Parsetree.Ptyp_extension x0 -> - Ast_414.Parsetree.Ptyp_extension (copy_extension x0) -and copy_package_type : - Ast_500.Parsetree.package_type -> Ast_414.Parsetree.package_type = - fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_loc copy_Longident_t x0), (copy_core_type x1))) x1)) -and copy_row_field : - Ast_500.Parsetree.row_field -> Ast_414.Parsetree.row_field = - fun - { Ast_500.Parsetree.prf_desc = prf_desc; - Ast_500.Parsetree.prf_loc = prf_loc; - Ast_500.Parsetree.prf_attributes = prf_attributes } - -> - { - Ast_414.Parsetree.prf_desc = (copy_row_field_desc prf_desc); - Ast_414.Parsetree.prf_loc = (copy_location prf_loc); - Ast_414.Parsetree.prf_attributes = (copy_attributes prf_attributes) - } -and copy_row_field_desc : - Ast_500.Parsetree.row_field_desc -> Ast_414.Parsetree.row_field_desc = - function - | Ast_500.Parsetree.Rtag (x0, x1, x2) -> - Ast_414.Parsetree.Rtag - ((copy_loc copy_label x0), x1, (List.map copy_core_type x2)) - | Ast_500.Parsetree.Rinherit x0 -> - Ast_414.Parsetree.Rinherit (copy_core_type x0) -and copy_object_field : - Ast_500.Parsetree.object_field -> Ast_414.Parsetree.object_field = - fun - { Ast_500.Parsetree.pof_desc = pof_desc; - Ast_500.Parsetree.pof_loc = pof_loc; - Ast_500.Parsetree.pof_attributes = pof_attributes } - -> - { - Ast_414.Parsetree.pof_desc = (copy_object_field_desc pof_desc); - Ast_414.Parsetree.pof_loc = (copy_location pof_loc); - Ast_414.Parsetree.pof_attributes = (copy_attributes pof_attributes) - } -and copy_attributes : - Ast_500.Parsetree.attributes -> Ast_414.Parsetree.attributes = - fun x -> List.map copy_attribute x -and copy_attribute : - Ast_500.Parsetree.attribute -> Ast_414.Parsetree.attribute = - fun - { Ast_500.Parsetree.attr_name = attr_name; - Ast_500.Parsetree.attr_payload = attr_payload; - Ast_500.Parsetree.attr_loc = attr_loc } - -> - { - Ast_414.Parsetree.attr_name = (copy_loc (fun x -> x) attr_name); - Ast_414.Parsetree.attr_payload = (copy_payload attr_payload); - Ast_414.Parsetree.attr_loc = (copy_location attr_loc) - } -and copy_payload : Ast_500.Parsetree.payload -> Ast_414.Parsetree.payload = - function - | Ast_500.Parsetree.PStr x0 -> Ast_414.Parsetree.PStr (copy_structure x0) - | Ast_500.Parsetree.PSig x0 -> Ast_414.Parsetree.PSig (copy_signature x0) - | Ast_500.Parsetree.PTyp x0 -> Ast_414.Parsetree.PTyp (copy_core_type x0) - | Ast_500.Parsetree.PPat (x0, x1) -> - Ast_414.Parsetree.PPat - ((copy_pattern x0), (Option.map copy_expression x1)) -and copy_structure : - Ast_500.Parsetree.structure -> Ast_414.Parsetree.structure = - fun x -> List.map copy_structure_item x -and copy_structure_item : - Ast_500.Parsetree.structure_item -> Ast_414.Parsetree.structure_item = - fun - { Ast_500.Parsetree.pstr_desc = pstr_desc; - Ast_500.Parsetree.pstr_loc = pstr_loc } - -> - { - Ast_414.Parsetree.pstr_desc = (copy_structure_item_desc pstr_desc); - Ast_414.Parsetree.pstr_loc = (copy_location pstr_loc) - } -and copy_structure_item_desc : - Ast_500.Parsetree.structure_item_desc -> - Ast_414.Parsetree.structure_item_desc - = - function - | Ast_500.Parsetree.Pstr_eval (x0, x1) -> - Ast_414.Parsetree.Pstr_eval - ((copy_expression x0), (copy_attributes x1)) - | Ast_500.Parsetree.Pstr_value (x0, x1) -> - Ast_414.Parsetree.Pstr_value - ((copy_rec_flag x0), (List.map copy_value_binding x1)) - | Ast_500.Parsetree.Pstr_primitive x0 -> - Ast_414.Parsetree.Pstr_primitive (copy_value_description x0) - | Ast_500.Parsetree.Pstr_type (x0, x1) -> - Ast_414.Parsetree.Pstr_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_500.Parsetree.Pstr_typext x0 -> - Ast_414.Parsetree.Pstr_typext (copy_type_extension x0) - | Ast_500.Parsetree.Pstr_exception x0 -> - Ast_414.Parsetree.Pstr_exception (copy_type_exception x0) - | Ast_500.Parsetree.Pstr_module x0 -> - Ast_414.Parsetree.Pstr_module (copy_module_binding x0) - | Ast_500.Parsetree.Pstr_recmodule x0 -> - Ast_414.Parsetree.Pstr_recmodule (List.map copy_module_binding x0) - | Ast_500.Parsetree.Pstr_modtype x0 -> - Ast_414.Parsetree.Pstr_modtype (copy_module_type_declaration x0) - | Ast_500.Parsetree.Pstr_open x0 -> - Ast_414.Parsetree.Pstr_open (copy_open_declaration x0) - | Ast_500.Parsetree.Pstr_class x0 -> - Ast_414.Parsetree.Pstr_class (List.map copy_class_declaration x0) - | Ast_500.Parsetree.Pstr_class_type x0 -> - Ast_414.Parsetree.Pstr_class_type - (List.map copy_class_type_declaration x0) - | Ast_500.Parsetree.Pstr_include x0 -> - Ast_414.Parsetree.Pstr_include (copy_include_declaration x0) - | Ast_500.Parsetree.Pstr_attribute x0 -> - Ast_414.Parsetree.Pstr_attribute (copy_attribute x0) - | Ast_500.Parsetree.Pstr_extension (x0, x1) -> - Ast_414.Parsetree.Pstr_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_include_declaration : - Ast_500.Parsetree.include_declaration -> - Ast_414.Parsetree.include_declaration - = fun x -> copy_include_infos copy_module_expr x -and copy_class_declaration : - Ast_500.Parsetree.class_declaration -> Ast_414.Parsetree.class_declaration - = fun x -> copy_class_infos copy_class_expr x -and copy_class_expr : - Ast_500.Parsetree.class_expr -> Ast_414.Parsetree.class_expr = - fun - { Ast_500.Parsetree.pcl_desc = pcl_desc; - Ast_500.Parsetree.pcl_loc = pcl_loc; - Ast_500.Parsetree.pcl_attributes = pcl_attributes } - -> - { - Ast_414.Parsetree.pcl_desc = (copy_class_expr_desc pcl_desc); - Ast_414.Parsetree.pcl_loc = (copy_location pcl_loc); - Ast_414.Parsetree.pcl_attributes = (copy_attributes pcl_attributes) - } -and copy_class_expr_desc : - Ast_500.Parsetree.class_expr_desc -> Ast_414.Parsetree.class_expr_desc = - function - | Ast_500.Parsetree.Pcl_constr (x0, x1) -> - Ast_414.Parsetree.Pcl_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_500.Parsetree.Pcl_structure x0 -> - Ast_414.Parsetree.Pcl_structure (copy_class_structure x0) - | Ast_500.Parsetree.Pcl_fun (x0, x1, x2, x3) -> - Ast_414.Parsetree.Pcl_fun - ((copy_arg_label x0), (Option.map copy_expression x1), - (copy_pattern x2), (copy_class_expr x3)) - | Ast_500.Parsetree.Pcl_apply (x0, x1) -> - Ast_414.Parsetree.Pcl_apply - ((copy_class_expr x0), - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_arg_label x0), (copy_expression x1))) x1)) - | Ast_500.Parsetree.Pcl_let (x0, x1, x2) -> - Ast_414.Parsetree.Pcl_let - ((copy_rec_flag x0), (List.map copy_value_binding x1), - (copy_class_expr x2)) - | Ast_500.Parsetree.Pcl_constraint (x0, x1) -> - Ast_414.Parsetree.Pcl_constraint - ((copy_class_expr x0), (copy_class_type x1)) - | Ast_500.Parsetree.Pcl_extension x0 -> - Ast_414.Parsetree.Pcl_extension (copy_extension x0) - | Ast_500.Parsetree.Pcl_open (x0, x1) -> - Ast_414.Parsetree.Pcl_open - ((copy_open_description x0), (copy_class_expr x1)) -and copy_class_structure : - Ast_500.Parsetree.class_structure -> Ast_414.Parsetree.class_structure = - fun - { Ast_500.Parsetree.pcstr_self = pcstr_self; - Ast_500.Parsetree.pcstr_fields = pcstr_fields } - -> - { - Ast_414.Parsetree.pcstr_self = (copy_pattern pcstr_self); - Ast_414.Parsetree.pcstr_fields = - (List.map copy_class_field pcstr_fields) - } -and copy_class_field : - Ast_500.Parsetree.class_field -> Ast_414.Parsetree.class_field = - fun - { Ast_500.Parsetree.pcf_desc = pcf_desc; - Ast_500.Parsetree.pcf_loc = pcf_loc; - Ast_500.Parsetree.pcf_attributes = pcf_attributes } - -> - { - Ast_414.Parsetree.pcf_desc = (copy_class_field_desc pcf_desc); - Ast_414.Parsetree.pcf_loc = (copy_location pcf_loc); - Ast_414.Parsetree.pcf_attributes = (copy_attributes pcf_attributes) - } -and copy_class_field_desc : - Ast_500.Parsetree.class_field_desc -> Ast_414.Parsetree.class_field_desc = - function - | Ast_500.Parsetree.Pcf_inherit (x0, x1, x2) -> - Ast_414.Parsetree.Pcf_inherit - ((copy_override_flag x0), (copy_class_expr x1), - (Option.map (fun x -> copy_loc (fun x -> x) x) x2)) - | Ast_500.Parsetree.Pcf_val x0 -> - Ast_414.Parsetree.Pcf_val - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_class_field_kind x2))) - | Ast_500.Parsetree.Pcf_method x0 -> - Ast_414.Parsetree.Pcf_method - (let (x0, x1, x2) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_class_field_kind x2))) - | Ast_500.Parsetree.Pcf_constraint x0 -> - Ast_414.Parsetree.Pcf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_500.Parsetree.Pcf_initializer x0 -> - Ast_414.Parsetree.Pcf_initializer (copy_expression x0) - | Ast_500.Parsetree.Pcf_attribute x0 -> - Ast_414.Parsetree.Pcf_attribute (copy_attribute x0) - | Ast_500.Parsetree.Pcf_extension x0 -> - Ast_414.Parsetree.Pcf_extension (copy_extension x0) -and copy_class_field_kind : - Ast_500.Parsetree.class_field_kind -> Ast_414.Parsetree.class_field_kind = - function - | Ast_500.Parsetree.Cfk_virtual x0 -> - Ast_414.Parsetree.Cfk_virtual (copy_core_type x0) - | Ast_500.Parsetree.Cfk_concrete (x0, x1) -> - Ast_414.Parsetree.Cfk_concrete - ((copy_override_flag x0), (copy_expression x1)) -and copy_open_declaration : - Ast_500.Parsetree.open_declaration -> Ast_414.Parsetree.open_declaration = - fun x -> copy_open_infos copy_module_expr x -and copy_module_binding : - Ast_500.Parsetree.module_binding -> Ast_414.Parsetree.module_binding = - fun - { Ast_500.Parsetree.pmb_name = pmb_name; - Ast_500.Parsetree.pmb_expr = pmb_expr; - Ast_500.Parsetree.pmb_attributes = pmb_attributes; - Ast_500.Parsetree.pmb_loc = pmb_loc } - -> - { - Ast_414.Parsetree.pmb_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmb_name); - Ast_414.Parsetree.pmb_expr = (copy_module_expr pmb_expr); - Ast_414.Parsetree.pmb_attributes = (copy_attributes pmb_attributes); - Ast_414.Parsetree.pmb_loc = (copy_location pmb_loc) - } -and copy_module_expr : - Ast_500.Parsetree.module_expr -> Ast_414.Parsetree.module_expr = - fun - { Ast_500.Parsetree.pmod_desc = pmod_desc; - Ast_500.Parsetree.pmod_loc = pmod_loc; - Ast_500.Parsetree.pmod_attributes = pmod_attributes } - -> - { - Ast_414.Parsetree.pmod_desc = (copy_module_expr_desc pmod_desc); - Ast_414.Parsetree.pmod_loc = (copy_location pmod_loc); - Ast_414.Parsetree.pmod_attributes = (copy_attributes pmod_attributes) - } -and copy_module_expr_desc : - Ast_500.Parsetree.module_expr_desc -> Ast_414.Parsetree.module_expr_desc = - function - | Ast_500.Parsetree.Pmod_ident x0 -> - Ast_414.Parsetree.Pmod_ident (copy_loc copy_Longident_t x0) - | Ast_500.Parsetree.Pmod_structure x0 -> - Ast_414.Parsetree.Pmod_structure (copy_structure x0) - | Ast_500.Parsetree.Pmod_functor (x0, x1) -> - Ast_414.Parsetree.Pmod_functor - ((copy_functor_parameter x0), (copy_module_expr x1)) - | Ast_500.Parsetree.Pmod_apply (x0, x1) -> - Ast_414.Parsetree.Pmod_apply - ((copy_module_expr x0), (copy_module_expr x1)) - | Ast_500.Parsetree.Pmod_constraint (x0, x1) -> - Ast_414.Parsetree.Pmod_constraint - ((copy_module_expr x0), (copy_module_type x1)) - | Ast_500.Parsetree.Pmod_unpack x0 -> - Ast_414.Parsetree.Pmod_unpack (copy_expression x0) - | Ast_500.Parsetree.Pmod_extension x0 -> - Ast_414.Parsetree.Pmod_extension (copy_extension x0) -and copy_functor_parameter : - Ast_500.Parsetree.functor_parameter -> Ast_414.Parsetree.functor_parameter - = - function - | Ast_500.Parsetree.Unit -> Ast_414.Parsetree.Unit - | Ast_500.Parsetree.Named (x0, x1) -> - Ast_414.Parsetree.Named - ((copy_loc (fun x -> Option.map (fun x -> x) x) x0), - (copy_module_type x1)) -and copy_module_type : - Ast_500.Parsetree.module_type -> Ast_414.Parsetree.module_type = - fun - { Ast_500.Parsetree.pmty_desc = pmty_desc; - Ast_500.Parsetree.pmty_loc = pmty_loc; - Ast_500.Parsetree.pmty_attributes = pmty_attributes } - -> - { - Ast_414.Parsetree.pmty_desc = (copy_module_type_desc pmty_desc); - Ast_414.Parsetree.pmty_loc = (copy_location pmty_loc); - Ast_414.Parsetree.pmty_attributes = (copy_attributes pmty_attributes) - } -and copy_module_type_desc : - Ast_500.Parsetree.module_type_desc -> Ast_414.Parsetree.module_type_desc = - function - | Ast_500.Parsetree.Pmty_ident x0 -> - Ast_414.Parsetree.Pmty_ident (copy_loc copy_Longident_t x0) - | Ast_500.Parsetree.Pmty_signature x0 -> - Ast_414.Parsetree.Pmty_signature (copy_signature x0) - | Ast_500.Parsetree.Pmty_functor (x0, x1) -> - Ast_414.Parsetree.Pmty_functor - ((copy_functor_parameter x0), (copy_module_type x1)) - | Ast_500.Parsetree.Pmty_with (x0, x1) -> - Ast_414.Parsetree.Pmty_with - ((copy_module_type x0), (List.map copy_with_constraint x1)) - | Ast_500.Parsetree.Pmty_typeof x0 -> - Ast_414.Parsetree.Pmty_typeof (copy_module_expr x0) - | Ast_500.Parsetree.Pmty_extension x0 -> - Ast_414.Parsetree.Pmty_extension (copy_extension x0) - | Ast_500.Parsetree.Pmty_alias x0 -> - Ast_414.Parsetree.Pmty_alias (copy_loc copy_Longident_t x0) -and copy_with_constraint : - Ast_500.Parsetree.with_constraint -> Ast_414.Parsetree.with_constraint = - function - | Ast_500.Parsetree.Pwith_type (x0, x1) -> - Ast_414.Parsetree.Pwith_type - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_500.Parsetree.Pwith_module (x0, x1) -> - Ast_414.Parsetree.Pwith_module - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) - | Ast_500.Parsetree.Pwith_modtype (x0, x1) -> - Ast_414.Parsetree.Pwith_modtype - ((copy_loc copy_Longident_t x0), (copy_module_type x1)) - | Ast_500.Parsetree.Pwith_modtypesubst (x0, x1) -> - Ast_414.Parsetree.Pwith_modtypesubst - ((copy_loc copy_Longident_t x0), (copy_module_type x1)) - | Ast_500.Parsetree.Pwith_typesubst (x0, x1) -> - Ast_414.Parsetree.Pwith_typesubst - ((copy_loc copy_Longident_t x0), (copy_type_declaration x1)) - | Ast_500.Parsetree.Pwith_modsubst (x0, x1) -> - Ast_414.Parsetree.Pwith_modsubst - ((copy_loc copy_Longident_t x0), (copy_loc copy_Longident_t x1)) -and copy_signature : - Ast_500.Parsetree.signature -> Ast_414.Parsetree.signature = - fun x -> List.map copy_signature_item x -and copy_signature_item : - Ast_500.Parsetree.signature_item -> Ast_414.Parsetree.signature_item = - fun - { Ast_500.Parsetree.psig_desc = psig_desc; - Ast_500.Parsetree.psig_loc = psig_loc } - -> - { - Ast_414.Parsetree.psig_desc = (copy_signature_item_desc psig_desc); - Ast_414.Parsetree.psig_loc = (copy_location psig_loc) - } -and copy_signature_item_desc : - Ast_500.Parsetree.signature_item_desc -> - Ast_414.Parsetree.signature_item_desc - = - function - | Ast_500.Parsetree.Psig_value x0 -> - Ast_414.Parsetree.Psig_value (copy_value_description x0) - | Ast_500.Parsetree.Psig_type (x0, x1) -> - Ast_414.Parsetree.Psig_type - ((copy_rec_flag x0), (List.map copy_type_declaration x1)) - | Ast_500.Parsetree.Psig_typesubst x0 -> - Ast_414.Parsetree.Psig_typesubst (List.map copy_type_declaration x0) - | Ast_500.Parsetree.Psig_typext x0 -> - Ast_414.Parsetree.Psig_typext (copy_type_extension x0) - | Ast_500.Parsetree.Psig_exception x0 -> - Ast_414.Parsetree.Psig_exception (copy_type_exception x0) - | Ast_500.Parsetree.Psig_module x0 -> - Ast_414.Parsetree.Psig_module (copy_module_declaration x0) - | Ast_500.Parsetree.Psig_modsubst x0 -> - Ast_414.Parsetree.Psig_modsubst (copy_module_substitution x0) - | Ast_500.Parsetree.Psig_recmodule x0 -> - Ast_414.Parsetree.Psig_recmodule (List.map copy_module_declaration x0) - | Ast_500.Parsetree.Psig_modtype x0 -> - Ast_414.Parsetree.Psig_modtype (copy_module_type_declaration x0) - | Ast_500.Parsetree.Psig_modtypesubst x0 -> - Ast_414.Parsetree.Psig_modtypesubst (copy_module_type_declaration x0) - | Ast_500.Parsetree.Psig_open x0 -> - Ast_414.Parsetree.Psig_open (copy_open_description x0) - | Ast_500.Parsetree.Psig_include x0 -> - Ast_414.Parsetree.Psig_include (copy_include_description x0) - | Ast_500.Parsetree.Psig_class x0 -> - Ast_414.Parsetree.Psig_class (List.map copy_class_description x0) - | Ast_500.Parsetree.Psig_class_type x0 -> - Ast_414.Parsetree.Psig_class_type - (List.map copy_class_type_declaration x0) - | Ast_500.Parsetree.Psig_attribute x0 -> - Ast_414.Parsetree.Psig_attribute (copy_attribute x0) - | Ast_500.Parsetree.Psig_extension (x0, x1) -> - Ast_414.Parsetree.Psig_extension - ((copy_extension x0), (copy_attributes x1)) -and copy_class_type_declaration : - Ast_500.Parsetree.class_type_declaration -> - Ast_414.Parsetree.class_type_declaration - = fun x -> copy_class_infos copy_class_type x -and copy_class_description : - Ast_500.Parsetree.class_description -> Ast_414.Parsetree.class_description - = fun x -> copy_class_infos copy_class_type x -and copy_class_type : - Ast_500.Parsetree.class_type -> Ast_414.Parsetree.class_type = - fun - { Ast_500.Parsetree.pcty_desc = pcty_desc; - Ast_500.Parsetree.pcty_loc = pcty_loc; - Ast_500.Parsetree.pcty_attributes = pcty_attributes } - -> - { - Ast_414.Parsetree.pcty_desc = (copy_class_type_desc pcty_desc); - Ast_414.Parsetree.pcty_loc = (copy_location pcty_loc); - Ast_414.Parsetree.pcty_attributes = (copy_attributes pcty_attributes) - } -and copy_class_type_desc : - Ast_500.Parsetree.class_type_desc -> Ast_414.Parsetree.class_type_desc = - function - | Ast_500.Parsetree.Pcty_constr (x0, x1) -> - Ast_414.Parsetree.Pcty_constr - ((copy_loc copy_Longident_t x0), (List.map copy_core_type x1)) - | Ast_500.Parsetree.Pcty_signature x0 -> - Ast_414.Parsetree.Pcty_signature (copy_class_signature x0) - | Ast_500.Parsetree.Pcty_arrow (x0, x1, x2) -> - Ast_414.Parsetree.Pcty_arrow - ((copy_arg_label x0), (copy_core_type x1), (copy_class_type x2)) - | Ast_500.Parsetree.Pcty_extension x0 -> - Ast_414.Parsetree.Pcty_extension (copy_extension x0) - | Ast_500.Parsetree.Pcty_open (x0, x1) -> - Ast_414.Parsetree.Pcty_open - ((copy_open_description x0), (copy_class_type x1)) -and copy_class_signature : - Ast_500.Parsetree.class_signature -> Ast_414.Parsetree.class_signature = - fun - { Ast_500.Parsetree.pcsig_self = pcsig_self; - Ast_500.Parsetree.pcsig_fields = pcsig_fields } - -> - { - Ast_414.Parsetree.pcsig_self = (copy_core_type pcsig_self); - Ast_414.Parsetree.pcsig_fields = - (List.map copy_class_type_field pcsig_fields) - } -and copy_class_type_field : - Ast_500.Parsetree.class_type_field -> Ast_414.Parsetree.class_type_field = - fun - { Ast_500.Parsetree.pctf_desc = pctf_desc; - Ast_500.Parsetree.pctf_loc = pctf_loc; - Ast_500.Parsetree.pctf_attributes = pctf_attributes } - -> - { - Ast_414.Parsetree.pctf_desc = (copy_class_type_field_desc pctf_desc); - Ast_414.Parsetree.pctf_loc = (copy_location pctf_loc); - Ast_414.Parsetree.pctf_attributes = (copy_attributes pctf_attributes) - } -and copy_class_type_field_desc : - Ast_500.Parsetree.class_type_field_desc -> - Ast_414.Parsetree.class_type_field_desc - = - function - | Ast_500.Parsetree.Pctf_inherit x0 -> - Ast_414.Parsetree.Pctf_inherit (copy_class_type x0) - | Ast_500.Parsetree.Pctf_val x0 -> - Ast_414.Parsetree.Pctf_val - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_mutable_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_500.Parsetree.Pctf_method x0 -> - Ast_414.Parsetree.Pctf_method - (let (x0, x1, x2, x3) = x0 in - ((copy_loc copy_label x0), (copy_private_flag x1), - (copy_virtual_flag x2), (copy_core_type x3))) - | Ast_500.Parsetree.Pctf_constraint x0 -> - Ast_414.Parsetree.Pctf_constraint - (let (x0, x1) = x0 in ((copy_core_type x0), (copy_core_type x1))) - | Ast_500.Parsetree.Pctf_attribute x0 -> - Ast_414.Parsetree.Pctf_attribute (copy_attribute x0) - | Ast_500.Parsetree.Pctf_extension x0 -> - Ast_414.Parsetree.Pctf_extension (copy_extension x0) -and copy_extension : - Ast_500.Parsetree.extension -> Ast_414.Parsetree.extension = - fun x -> - let (x0, x1) = x in ((copy_loc (fun x -> x) x0), (copy_payload x1)) -and copy_class_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_500.Parsetree.class_infos -> 'g0 Ast_414.Parsetree.class_infos - = - fun f0 -> - fun - { Ast_500.Parsetree.pci_virt = pci_virt; - Ast_500.Parsetree.pci_params = pci_params; - Ast_500.Parsetree.pci_name = pci_name; - Ast_500.Parsetree.pci_expr = pci_expr; - Ast_500.Parsetree.pci_loc = pci_loc; - Ast_500.Parsetree.pci_attributes = pci_attributes } - -> - { - Ast_414.Parsetree.pci_virt = (copy_virtual_flag pci_virt); - Ast_414.Parsetree.pci_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) pci_params); - Ast_414.Parsetree.pci_name = (copy_loc (fun x -> x) pci_name); - Ast_414.Parsetree.pci_expr = (f0 pci_expr); - Ast_414.Parsetree.pci_loc = (copy_location pci_loc); - Ast_414.Parsetree.pci_attributes = (copy_attributes pci_attributes) - } -and copy_virtual_flag : - Ast_500.Asttypes.virtual_flag -> Ast_414.Asttypes.virtual_flag = - function - | Ast_500.Asttypes.Virtual -> Ast_414.Asttypes.Virtual - | Ast_500.Asttypes.Concrete -> Ast_414.Asttypes.Concrete -and copy_include_description : - Ast_500.Parsetree.include_description -> - Ast_414.Parsetree.include_description - = fun x -> copy_include_infos copy_module_type x -and copy_include_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_500.Parsetree.include_infos -> - 'g0 Ast_414.Parsetree.include_infos - = - fun f0 -> - fun - { Ast_500.Parsetree.pincl_mod = pincl_mod; - Ast_500.Parsetree.pincl_loc = pincl_loc; - Ast_500.Parsetree.pincl_attributes = pincl_attributes } - -> - { - Ast_414.Parsetree.pincl_mod = (f0 pincl_mod); - Ast_414.Parsetree.pincl_loc = (copy_location pincl_loc); - Ast_414.Parsetree.pincl_attributes = - (copy_attributes pincl_attributes) - } -and copy_open_description : - Ast_500.Parsetree.open_description -> Ast_414.Parsetree.open_description = - fun x -> copy_open_infos (fun x -> copy_loc copy_Longident_t x) x -and copy_open_infos : - 'f0 'g0 . - ('f0 -> 'g0) -> - 'f0 Ast_500.Parsetree.open_infos -> 'g0 Ast_414.Parsetree.open_infos - = - fun f0 -> - fun - { Ast_500.Parsetree.popen_expr = popen_expr; - Ast_500.Parsetree.popen_override = popen_override; - Ast_500.Parsetree.popen_loc = popen_loc; - Ast_500.Parsetree.popen_attributes = popen_attributes } - -> - { - Ast_414.Parsetree.popen_expr = (f0 popen_expr); - Ast_414.Parsetree.popen_override = - (copy_override_flag popen_override); - Ast_414.Parsetree.popen_loc = (copy_location popen_loc); - Ast_414.Parsetree.popen_attributes = - (copy_attributes popen_attributes) - } -and copy_override_flag : - Ast_500.Asttypes.override_flag -> Ast_414.Asttypes.override_flag = - function - | Ast_500.Asttypes.Override -> Ast_414.Asttypes.Override - | Ast_500.Asttypes.Fresh -> Ast_414.Asttypes.Fresh -and copy_module_type_declaration : - Ast_500.Parsetree.module_type_declaration -> - Ast_414.Parsetree.module_type_declaration - = - fun - { Ast_500.Parsetree.pmtd_name = pmtd_name; - Ast_500.Parsetree.pmtd_type = pmtd_type; - Ast_500.Parsetree.pmtd_attributes = pmtd_attributes; - Ast_500.Parsetree.pmtd_loc = pmtd_loc } - -> - { - Ast_414.Parsetree.pmtd_name = (copy_loc (fun x -> x) pmtd_name); - Ast_414.Parsetree.pmtd_type = (Option.map copy_module_type pmtd_type); - Ast_414.Parsetree.pmtd_attributes = (copy_attributes pmtd_attributes); - Ast_414.Parsetree.pmtd_loc = (copy_location pmtd_loc) - } -and copy_module_substitution : - Ast_500.Parsetree.module_substitution -> - Ast_414.Parsetree.module_substitution - = - fun - { Ast_500.Parsetree.pms_name = pms_name; - Ast_500.Parsetree.pms_manifest = pms_manifest; - Ast_500.Parsetree.pms_attributes = pms_attributes; - Ast_500.Parsetree.pms_loc = pms_loc } - -> - { - Ast_414.Parsetree.pms_name = (copy_loc (fun x -> x) pms_name); - Ast_414.Parsetree.pms_manifest = - (copy_loc copy_Longident_t pms_manifest); - Ast_414.Parsetree.pms_attributes = (copy_attributes pms_attributes); - Ast_414.Parsetree.pms_loc = (copy_location pms_loc) - } -and copy_module_declaration : - Ast_500.Parsetree.module_declaration -> - Ast_414.Parsetree.module_declaration - = - fun - { Ast_500.Parsetree.pmd_name = pmd_name; - Ast_500.Parsetree.pmd_type = pmd_type; - Ast_500.Parsetree.pmd_attributes = pmd_attributes; - Ast_500.Parsetree.pmd_loc = pmd_loc } - -> - { - Ast_414.Parsetree.pmd_name = - (copy_loc (fun x -> Option.map (fun x -> x) x) pmd_name); - Ast_414.Parsetree.pmd_type = (copy_module_type pmd_type); - Ast_414.Parsetree.pmd_attributes = (copy_attributes pmd_attributes); - Ast_414.Parsetree.pmd_loc = (copy_location pmd_loc) - } -and copy_type_exception : - Ast_500.Parsetree.type_exception -> Ast_414.Parsetree.type_exception = - fun - { Ast_500.Parsetree.ptyexn_constructor = ptyexn_constructor; - Ast_500.Parsetree.ptyexn_loc = ptyexn_loc; - Ast_500.Parsetree.ptyexn_attributes = ptyexn_attributes } - -> - { - Ast_414.Parsetree.ptyexn_constructor = - (copy_extension_constructor ptyexn_constructor); - Ast_414.Parsetree.ptyexn_loc = (copy_location ptyexn_loc); - Ast_414.Parsetree.ptyexn_attributes = - (copy_attributes ptyexn_attributes) - } -and copy_type_extension : - Ast_500.Parsetree.type_extension -> Ast_414.Parsetree.type_extension = - fun - { Ast_500.Parsetree.ptyext_path = ptyext_path; - Ast_500.Parsetree.ptyext_params = ptyext_params; - Ast_500.Parsetree.ptyext_constructors = ptyext_constructors; - Ast_500.Parsetree.ptyext_private = ptyext_private; - Ast_500.Parsetree.ptyext_loc = ptyext_loc; - Ast_500.Parsetree.ptyext_attributes = ptyext_attributes } - -> - { - Ast_414.Parsetree.ptyext_path = (copy_loc copy_Longident_t ptyext_path); - Ast_414.Parsetree.ptyext_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) ptyext_params); - Ast_414.Parsetree.ptyext_constructors = - (List.map copy_extension_constructor ptyext_constructors); - Ast_414.Parsetree.ptyext_private = (copy_private_flag ptyext_private); - Ast_414.Parsetree.ptyext_loc = (copy_location ptyext_loc); - Ast_414.Parsetree.ptyext_attributes = - (copy_attributes ptyext_attributes) - } -and copy_extension_constructor : - Ast_500.Parsetree.extension_constructor -> - Ast_414.Parsetree.extension_constructor - = - fun - { Ast_500.Parsetree.pext_name = pext_name; - Ast_500.Parsetree.pext_kind = pext_kind; - Ast_500.Parsetree.pext_loc = pext_loc; - Ast_500.Parsetree.pext_attributes = pext_attributes } - -> - { - Ast_414.Parsetree.pext_name = (copy_loc (fun x -> x) pext_name); - Ast_414.Parsetree.pext_kind = - (copy_extension_constructor_kind pext_kind); - Ast_414.Parsetree.pext_loc = (copy_location pext_loc); - Ast_414.Parsetree.pext_attributes = (copy_attributes pext_attributes) - } -and copy_extension_constructor_kind : - Ast_500.Parsetree.extension_constructor_kind -> - Ast_414.Parsetree.extension_constructor_kind - = - function - | Ast_500.Parsetree.Pext_decl (x0, x1, x2) -> - Ast_414.Parsetree.Pext_decl - ((List.map (fun x -> copy_loc (fun x -> x) x) x0), - (copy_constructor_arguments x1), (Option.map copy_core_type x2)) - | Ast_500.Parsetree.Pext_rebind x0 -> - Ast_414.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0) -and copy_type_declaration : - Ast_500.Parsetree.type_declaration -> Ast_414.Parsetree.type_declaration = - fun - { Ast_500.Parsetree.ptype_name = ptype_name; - Ast_500.Parsetree.ptype_params = ptype_params; - Ast_500.Parsetree.ptype_cstrs = ptype_cstrs; - Ast_500.Parsetree.ptype_kind = ptype_kind; - Ast_500.Parsetree.ptype_private = ptype_private; - Ast_500.Parsetree.ptype_manifest = ptype_manifest; - Ast_500.Parsetree.ptype_attributes = ptype_attributes; - Ast_500.Parsetree.ptype_loc = ptype_loc } - -> - { - Ast_414.Parsetree.ptype_name = (copy_loc (fun x -> x) ptype_name); - Ast_414.Parsetree.ptype_params = - (List.map - (fun x -> - let (x0, x1) = x in - ((copy_core_type x0), - (let (x0, x1) = x1 in - ((copy_variance x0), (copy_injectivity x1))))) ptype_params); - Ast_414.Parsetree.ptype_cstrs = - (List.map - (fun x -> - let (x0, x1, x2) = x in - ((copy_core_type x0), (copy_core_type x1), (copy_location x2))) - ptype_cstrs); - Ast_414.Parsetree.ptype_kind = (copy_type_kind ptype_kind); - Ast_414.Parsetree.ptype_private = (copy_private_flag ptype_private); - Ast_414.Parsetree.ptype_manifest = - (Option.map copy_core_type ptype_manifest); - Ast_414.Parsetree.ptype_attributes = (copy_attributes ptype_attributes); - Ast_414.Parsetree.ptype_loc = (copy_location ptype_loc) - } -and copy_private_flag : - Ast_500.Asttypes.private_flag -> Ast_414.Asttypes.private_flag = - function - | Ast_500.Asttypes.Private -> Ast_414.Asttypes.Private - | Ast_500.Asttypes.Public -> Ast_414.Asttypes.Public -and copy_type_kind : - Ast_500.Parsetree.type_kind -> Ast_414.Parsetree.type_kind = - function - | Ast_500.Parsetree.Ptype_abstract -> Ast_414.Parsetree.Ptype_abstract - | Ast_500.Parsetree.Ptype_variant x0 -> - Ast_414.Parsetree.Ptype_variant - (List.map copy_constructor_declaration x0) - | Ast_500.Parsetree.Ptype_record x0 -> - Ast_414.Parsetree.Ptype_record (List.map copy_label_declaration x0) - | Ast_500.Parsetree.Ptype_open -> Ast_414.Parsetree.Ptype_open -and copy_constructor_declaration : - Ast_500.Parsetree.constructor_declaration -> - Ast_414.Parsetree.constructor_declaration - = - fun - { Ast_500.Parsetree.pcd_name = pcd_name; - Ast_500.Parsetree.pcd_vars = pcd_vars; - Ast_500.Parsetree.pcd_args = pcd_args; - Ast_500.Parsetree.pcd_res = pcd_res; - Ast_500.Parsetree.pcd_loc = pcd_loc; - Ast_500.Parsetree.pcd_attributes = pcd_attributes } - -> - { - Ast_414.Parsetree.pcd_name = (copy_loc (fun x -> x) pcd_name); - Ast_414.Parsetree.pcd_vars = - (List.map (fun x -> copy_loc (fun x -> x) x) pcd_vars); - Ast_414.Parsetree.pcd_args = (copy_constructor_arguments pcd_args); - Ast_414.Parsetree.pcd_res = (Option.map copy_core_type pcd_res); - Ast_414.Parsetree.pcd_loc = (copy_location pcd_loc); - Ast_414.Parsetree.pcd_attributes = (copy_attributes pcd_attributes) - } -and copy_constructor_arguments : - Ast_500.Parsetree.constructor_arguments -> - Ast_414.Parsetree.constructor_arguments - = - function - | Ast_500.Parsetree.Pcstr_tuple x0 -> - Ast_414.Parsetree.Pcstr_tuple (List.map copy_core_type x0) - | Ast_500.Parsetree.Pcstr_record x0 -> - Ast_414.Parsetree.Pcstr_record (List.map copy_label_declaration x0) -and copy_label_declaration : - Ast_500.Parsetree.label_declaration -> Ast_414.Parsetree.label_declaration - = - fun - { Ast_500.Parsetree.pld_name = pld_name; - Ast_500.Parsetree.pld_mutable = pld_mutable; - Ast_500.Parsetree.pld_type = pld_type; - Ast_500.Parsetree.pld_loc = pld_loc; - Ast_500.Parsetree.pld_attributes = pld_attributes } - -> - { - Ast_414.Parsetree.pld_name = (copy_loc (fun x -> x) pld_name); - Ast_414.Parsetree.pld_mutable = (copy_mutable_flag pld_mutable); - Ast_414.Parsetree.pld_type = (copy_core_type pld_type); - Ast_414.Parsetree.pld_loc = (copy_location pld_loc); - Ast_414.Parsetree.pld_attributes = (copy_attributes pld_attributes) - } -and copy_mutable_flag : - Ast_500.Asttypes.mutable_flag -> Ast_414.Asttypes.mutable_flag = - function - | Ast_500.Asttypes.Immutable -> Ast_414.Asttypes.Immutable - | Ast_500.Asttypes.Mutable -> Ast_414.Asttypes.Mutable -and copy_injectivity : - Ast_500.Asttypes.injectivity -> Ast_414.Asttypes.injectivity = - function - | Ast_500.Asttypes.Injective -> Ast_414.Asttypes.Injective - | Ast_500.Asttypes.NoInjectivity -> Ast_414.Asttypes.NoInjectivity -and copy_variance : Ast_500.Asttypes.variance -> Ast_414.Asttypes.variance = - function - | Ast_500.Asttypes.Covariant -> Ast_414.Asttypes.Covariant - | Ast_500.Asttypes.Contravariant -> Ast_414.Asttypes.Contravariant - | Ast_500.Asttypes.NoVariance -> Ast_414.Asttypes.NoVariance -and copy_value_description : - Ast_500.Parsetree.value_description -> Ast_414.Parsetree.value_description - = - fun - { Ast_500.Parsetree.pval_name = pval_name; - Ast_500.Parsetree.pval_type = pval_type; - Ast_500.Parsetree.pval_prim = pval_prim; - Ast_500.Parsetree.pval_attributes = pval_attributes; - Ast_500.Parsetree.pval_loc = pval_loc } - -> - { - Ast_414.Parsetree.pval_name = (copy_loc (fun x -> x) pval_name); - Ast_414.Parsetree.pval_type = (copy_core_type pval_type); - Ast_414.Parsetree.pval_prim = (List.map (fun x -> x) pval_prim); - Ast_414.Parsetree.pval_attributes = (copy_attributes pval_attributes); - Ast_414.Parsetree.pval_loc = (copy_location pval_loc) - } -and copy_object_field_desc : - Ast_500.Parsetree.object_field_desc -> Ast_414.Parsetree.object_field_desc - = - function - | Ast_500.Parsetree.Otag (x0, x1) -> - Ast_414.Parsetree.Otag ((copy_loc copy_label x0), (copy_core_type x1)) - | Ast_500.Parsetree.Oinherit x0 -> - Ast_414.Parsetree.Oinherit (copy_core_type x0) -and copy_arg_label : Ast_500.Asttypes.arg_label -> Ast_414.Asttypes.arg_label - = - function - | Ast_500.Asttypes.Nolabel -> Ast_414.Asttypes.Nolabel - | Ast_500.Asttypes.Labelled x0 -> Ast_414.Asttypes.Labelled x0 - | Ast_500.Asttypes.Optional x0 -> Ast_414.Asttypes.Optional x0 -and copy_closed_flag : - Ast_500.Asttypes.closed_flag -> Ast_414.Asttypes.closed_flag = - function - | Ast_500.Asttypes.Closed -> Ast_414.Asttypes.Closed - | Ast_500.Asttypes.Open -> Ast_414.Asttypes.Open -and copy_label : Ast_500.Asttypes.label -> Ast_414.Asttypes.label = - fun x -> x -and copy_rec_flag : Ast_500.Asttypes.rec_flag -> Ast_414.Asttypes.rec_flag = - function - | Ast_500.Asttypes.Nonrecursive -> Ast_414.Asttypes.Nonrecursive - | Ast_500.Asttypes.Recursive -> Ast_414.Asttypes.Recursive -and copy_constant : Ast_500.Parsetree.constant -> Ast_414.Parsetree.constant - = - function - | Ast_500.Parsetree.Pconst_integer (x0, x1) -> - Ast_414.Parsetree.Pconst_integer (x0, (Option.map (fun x -> x) x1)) - | Ast_500.Parsetree.Pconst_char x0 -> Ast_414.Parsetree.Pconst_char x0 - | Ast_500.Parsetree.Pconst_string (x0, x1, x2) -> - Ast_414.Parsetree.Pconst_string - (x0, (copy_location x1), (Option.map (fun x -> x) x2)) - | Ast_500.Parsetree.Pconst_float (x0, x1) -> - Ast_414.Parsetree.Pconst_float (x0, (Option.map (fun x -> x) x1)) -and copy_Longident_t : Longident.t -> Longident.t = - function - | Longident.Lident x0 -> Longident.Lident x0 - | Longident.Ldot (x0, x1) -> Longident.Ldot ((copy_Longident_t x0), x1) - | Longident.Lapply (x0, x1) -> - Longident.Lapply ((copy_Longident_t x0), (copy_Longident_t x1)) -and copy_loc : - 'f0 'g0 . - ('f0 -> 'g0) -> 'f0 Ast_500.Asttypes.loc -> 'g0 Ast_414.Asttypes.loc - = - fun f0 -> - fun { Ast_500.Asttypes.txt = txt; Ast_500.Asttypes.loc = loc } -> - { - Ast_414.Asttypes.txt = (f0 txt); - Ast_414.Asttypes.loc = (copy_location loc) - } -and copy_location : Location.t -> Location.t = - fun - { Location.loc_start = loc_start; Location.loc_end = loc_end; - Location.loc_ghost = loc_ghost } - -> - { - Location.loc_start = (copy_position loc_start); - Location.loc_end = (copy_position loc_end); - Location.loc_ghost = loc_ghost - } -and copy_position : Lexing.position -> Lexing.position = - fun - { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } - -> - { - Lexing.pos_fname = pos_fname; - Lexing.pos_lnum = pos_lnum; - Lexing.pos_bol = pos_bol; - Lexing.pos_cnum = pos_cnum - } diff --git a/src/vendored-omp/src/migrate_parsetree_ast_io.ml b/src/vendored-omp/src/migrate_parsetree_ast_io.ml deleted file mode 100644 index 6d6d529d0..000000000 --- a/src/vendored-omp/src/migrate_parsetree_ast_io.ml +++ /dev/null @@ -1,101 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml Migrate Parsetree *) -(* *) -(* Frédéric Bour *) -(* *) -(* Copyright 2017 Institut National de Recherche en Informatique et *) -(* en Automatique (INRIA). *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -type ast = - | Impl : (module Migrate_parsetree_versions.OCaml_version with - type Ast.Parsetree.structure = 'concrete) * 'concrete -> ast - | Intf : (module Migrate_parsetree_versions.OCaml_version with - type Ast.Parsetree.signature = 'concrete) * 'concrete -> ast - -type filename = string - -let magic_length = String.length Ast_402.Config.ast_impl_magic_number - -let read_magic ic = - let buf = Bytes.create magic_length in - let len = input ic buf 0 magic_length in - let s = Bytes.sub_string buf 0 len in - if len = magic_length then - Ok s - else - Error s - -type read_error = - | Not_a_binary_ast of string - | Unknown_version of string - -let find_magic magic = - let rec loop = function - | [] -> - let prefix = String.sub magic 0 9 in - if prefix = String.sub Ast_402.Config.ast_impl_magic_number 0 9 || - prefix = String.sub Ast_402.Config.ast_intf_magic_number 0 9 then - Error (Unknown_version magic) - else - Error (Not_a_binary_ast magic) - | (module Frontend : Migrate_parsetree_versions.OCaml_version) :: tail -> - if Frontend.Ast.Config.ast_impl_magic_number = magic then - Ok (fun x -> Impl ((module Frontend), Obj.obj x)) - else if Frontend.Ast.Config.ast_intf_magic_number = magic then - Ok (fun x -> Intf ((module Frontend), Obj.obj x)) - else - loop tail - in - loop Migrate_parsetree_versions.all_versions - -let from_channel ic = - match read_magic ic with - | Error s -> Error (Not_a_binary_ast s) - | Ok s -> - match find_magic s with - | Ok inj -> - let filename : filename = input_value ic in - let payload = inj (input_value ic) in - Ok (filename, payload) - | Error _ as e -> e - -let from_bytes bytes pos = - if Bytes.length bytes - pos < magic_length then - Error (Not_a_binary_ast "") - else - let magic = Bytes.to_string (Bytes.sub bytes pos magic_length) in - match find_magic magic with - | Ok inj -> - let filename_pos = pos + magic_length in - let filename : filename = Marshal.from_bytes bytes filename_pos in - let payload_pos = filename_pos + Marshal.total_size bytes filename_pos in - let payload = inj (Marshal.from_bytes bytes payload_pos) in - Ok (filename, payload) - | Error _ as e -> e - -let decompose_ast = function - | Impl ((module Frontend), tree) -> - (Frontend.Ast.Config.ast_impl_magic_number, Obj.repr tree) - | Intf ((module Frontend), tree) -> - (Frontend.Ast.Config.ast_intf_magic_number, Obj.repr tree) - -let to_channel oc (filename : filename) x = - let magic_number, payload = decompose_ast x in - output_string oc magic_number; - output_value oc filename; - output_value oc payload - -let to_bytes (filename : filename) x = - let magic_number, payload = decompose_ast x in - Bytes.cat ( - Bytes.cat - (Bytes.of_string magic_number) - (Marshal.to_bytes filename []) - ) (Marshal.to_bytes payload []) diff --git a/src/vendored-omp/src/migrate_parsetree_ast_io.mli b/src/vendored-omp/src/migrate_parsetree_ast_io.mli deleted file mode 100644 index 41ab59ef8..000000000 --- a/src/vendored-omp/src/migrate_parsetree_ast_io.mli +++ /dev/null @@ -1,49 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml Migrate Parsetree *) -(* *) -(* Frédéric Bour *) -(* *) -(* Copyright 2017 Institut National de Recherche en Informatique et *) -(* en Automatique (INRIA). *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** A marshalled ast packs the ast with the corresponding version of the - frontend *) -type ast = - | Impl : (module Migrate_parsetree_versions.OCaml_version with - type Ast.Parsetree.structure = 'concrete) * 'concrete -> ast - | Intf : (module Migrate_parsetree_versions.OCaml_version with - type Ast.Parsetree.signature = 'concrete) * 'concrete -> ast - -(** A simple alias used for the filename of the source that produced an AST *) -type filename = string - -type read_error = - | Not_a_binary_ast of string - (** The input doesn't contain a binary AST. The argument corresponds - to the bytes from the input that were consumed. *) - | Unknown_version of string - (** The input contains a binary AST for an unknown version of OCaml. - The argument is the unknown magic number. *) - -(** Load a marshalled AST from a channel - - Any exception raised during unmarshalling (see [Marshal]) can escape. *) -val from_channel : in_channel -> (filename * ast, read_error) result - -(** Load a marshalled AST from a byte string. - - See [from_channel] description for exception that can be raised. *) -val from_bytes : bytes -> int -> (filename * ast, read_error) result - -(** Marshal an AST to a channel *) -val to_channel : out_channel -> filename -> ast -> unit - -(** Marshal an AST to a byte string *) -val to_bytes : filename -> ast -> bytes diff --git a/src/vendored-omp/src/migrate_parsetree_driver.ml b/src/vendored-omp/src/migrate_parsetree_driver.ml deleted file mode 100644 index 5d1ed626a..000000000 --- a/src/vendored-omp/src/migrate_parsetree_driver.ml +++ /dev/null @@ -1,599 +0,0 @@ -open Migrate_parsetree_versions -module Ast_io = Migrate_parsetree_ast_io - -(** {1 State a rewriter can access} *) - -type extra = .. - -type config = { - tool_name: string; - include_dirs : string list; - load_path : string list; - debug : bool; - for_package : string option; - extras : extra list; -} - -let make_config ~tool_name ?(include_dirs=[]) ?(load_path=[]) ?(debug=false) - ?for_package ?(extras=[]) () = - { tool_name - ; include_dirs - ; load_path - ; debug - ; for_package - ; extras - } - -type cookie = Cookie : 'types ocaml_version * 'types get_expression -> cookie - -type cookies = (string, cookie) Hashtbl.t - -let create_cookies () = Hashtbl.create 3 - -let global_cookie_table = create_cookies () - -let get_cookie table name version = - match - match Hashtbl.find table name with - | result -> Some result - | exception Not_found -> - match Ast_mapper.get_cookie name with - | Some expr -> Some (Cookie ((module OCaml_current), expr)) - | None -> - match Hashtbl.find global_cookie_table name with - | result -> Some result - | exception Not_found -> None - with - | None -> None - | Some (Cookie (version', expr)) -> - Some ((migrate version' version).copy_expression expr) - -let set_cookie table name version expr = - Hashtbl.replace table name (Cookie (version, expr)) - -let set_global_cookie name version expr = - set_cookie global_cookie_table name version expr - -let apply_cookies table = - Hashtbl.iter (fun name (Cookie (version, expr)) -> - Ast_mapper.set_cookie name - ((migrate version (module OCaml_current)).copy_expression expr) - ) table - -let initial_state () = - { - tool_name = Ast_mapper.tool_name (); - include_dirs = !Clflags.include_dirs; - load_path = Migrate_parsetree_compiler_functions.get_load_paths (); - debug = !Clflags.debug; - for_package = !Clflags.for_package; - extras = []; - } - -(** {1 Registering rewriters} *) - -type 'types rewriter = config -> cookies -> 'types get_mapper - -type rewriter_group = - Rewriters : 'types ocaml_version * (string * 'types rewriter) list -> rewriter_group - -let rewriter_group_names (Rewriters (_, l)) = List.map fst l - -let uniq_rewriter = Hashtbl.create 7 -module Pos_map = Map.Make(struct - type t = int - let compare : int -> int -> t = compare - end) -let registered_rewriters = ref Pos_map.empty - -let all_rewriters () = - Pos_map.bindings !registered_rewriters - |> List.map (fun (_, r) -> !r) - |> List.concat - -let uniq_arg = Hashtbl.create 7 -let registered_args_reset = ref [] -let registered_args = ref [] - -let () = - let set_cookie s = - match String.index s '=' with - | exception _ -> - raise (Arg.Bad "invalid cookie, must be of the form \"=\"") - | i -> - let name = String.sub s 0 i in - let value = String.sub s (i + 1) (String.length s - i - 1) in - let input_name = "" in - Location.input_name := input_name; - let lexbuf = Lexing.from_string value in - lexbuf.Lexing.lex_curr_p <- - { Lexing. - pos_fname = input_name - ; pos_lnum = 1 - ; pos_bol = 0 - ; pos_cnum = 0 - }; - let expr = Parse.expression lexbuf in - set_global_cookie name (module OCaml_current) expr - in - registered_args := - ("--cookie", Arg.String set_cookie, - "NAME=EXPR Set the cookie NAME to EXPR") :: !registered_args - -type ('types, 'version, 'rewriter) is_rewriter = - | Is_rewriter : ('types, 'types ocaml_version, 'types rewriter) is_rewriter - -let add_rewriter - (type types) (type version) (type rewriter) - (Is_rewriter : (types, version, rewriter) is_rewriter) - (version : version) name (rewriter : rewriter) = - let rec add_rewriter = function - | [] -> [Rewriters (version, [name, rewriter])] - | (Rewriters (version', rewriters) as x) :: xs -> - match compare_ocaml_version version version' with - | Eq -> Rewriters (version', (name, rewriter) :: rewriters) :: xs - | Lt -> Rewriters (version, [name, rewriter]) :: x :: xs - | Gt -> x :: add_rewriter xs - in - add_rewriter - -let register ~name ?reset_args ?(args=[]) ?(position=0) version rewriter = - (* Validate name *) - if name = "" then - invalid_arg "Migrate_parsetree_driver.register: name is empty"; - if Hashtbl.mem uniq_rewriter name then - invalid_arg ("Migrate_parsetree_driver.register: rewriter " ^ name ^ " has already been registered") - else Hashtbl.add uniq_rewriter name (); - (* Validate arguments *) - List.iter (fun (arg_name, _, _) -> - match Hashtbl.find uniq_arg arg_name with - | other_rewriter -> - invalid_arg (Printf.sprintf - "Migrate_parsetree_driver.register: argument %s is used by %s and %s" arg_name name other_rewriter) - | exception Not_found -> - Hashtbl.add uniq_arg arg_name name - ) args; - (* Register *) - begin match reset_args with - | None -> () - | Some f -> registered_args_reset := f :: !registered_args_reset - end; - registered_args := List.rev_append args !registered_args; - let r = - try - Pos_map.find position !registered_rewriters - with Not_found -> - let r = ref [] in - registered_rewriters := Pos_map.add position r !registered_rewriters; - r - in - r := add_rewriter Is_rewriter version name rewriter !r - -let registered_args () = List.rev !registered_args -let reset_args () = List.iter (fun f -> f ()) !registered_args_reset - -(** {1 Accessing or running registered rewriters} *) - -type ('types, 'version, 'tree) is_signature = - Signature : ('types, 'types ocaml_version, 'types get_signature) is_signature - -type ('types, 'version, 'tree) is_structure = - Structure : ('types, 'types ocaml_version, 'types get_structure) is_structure - -type some_structure = - | Str : (module Migrate_parsetree_versions.OCaml_version with - type Ast.Parsetree.structure = 'concrete) * 'concrete -> some_structure - -type some_signature = - | Sig : (module Migrate_parsetree_versions.OCaml_version with - type Ast.Parsetree.signature = 'concrete) * 'concrete -> some_signature - -let migrate_some_structure dst (Str ((module Version), st)) = - (migrate (module Version) dst).copy_structure st - -let migrate_some_signature dst (Sig ((module Version), sg)) = - (migrate (module Version) dst).copy_signature sg - -let rec rewrite_signature - : type types version tree. - config -> cookies -> - (types, version, tree) is_signature -> version -> tree -> - rewriter_group list -> some_signature - = fun (type types) (type version) (type tree) - config cookies - (Signature : (types, version, tree) is_signature) - (version : version) - (tree : tree) - -> function - | [] -> - let (module Version) = version in - Sig ((module Version), tree) - | Rewriters (version', rewriters) :: rest -> - let rewrite (_name, rewriter) tree = - let (module Version) = version' in - Version.Ast.map_signature (rewriter config cookies) tree - in - let tree = (migrate version version').copy_signature tree in - let tree = List.fold_right rewrite rewriters tree in - rewrite_signature config cookies Signature version' tree rest - -let rewrite_signature config version sg = - let cookies = create_cookies () in - let sg = - rewrite_signature config cookies Signature version sg - (all_rewriters ()) - in - apply_cookies cookies; - sg - -let rec rewrite_structure - : type types version tree. - config -> cookies -> - (types, version, tree) is_structure -> version -> tree -> - rewriter_group list -> some_structure - = fun (type types) (type version) (type tree) - config cookies - (Structure : (types, version, tree) is_structure) - (version : version) - (tree : tree) - -> function - | [] -> - let (module Version) = version in - Str ((module Version), tree) - | Rewriters (version', rewriters) :: rest -> - let rewriter (_name, rewriter) tree = - let (module Version) = version' in - Version.Ast.map_structure (rewriter config cookies) tree - in - let tree = (migrate version version').copy_structure tree in - let tree = List.fold_right rewriter rewriters tree in - rewrite_structure config cookies Structure version' tree rest - -let rewrite_structure config version st = - let cookies = create_cookies () in - let st = - rewrite_structure config cookies Structure version st - (all_rewriters ()) - in - apply_cookies cookies; - st - -let exit_or_raise ~exit_on_error f = - if not exit_on_error then - f () - else - try - f () - with - | Arg.Help text -> - print_string text; - exit 0 - | Arg.Bad text -> - prerr_string text; - exit 2 - | exn -> - Location.report_exception Format.err_formatter exn; - exit 1 - -let run_as_ast_mapper ?(exit_on_error = true) args = - let spec = registered_args () in - let args, usage = - let me = Filename.basename Sys.executable_name in - let args = match args with "--as-ppx" :: args -> args | args -> args in - (Array.of_list (me :: args), - Printf.sprintf "%s [options] " me) - in - reset_args (); - exit_or_raise ~exit_on_error begin fun () -> - Arg.parse_argv ~current:(ref 0) args spec - (fun arg -> raise (Arg.Bad (Printf.sprintf "invalid argument %S" arg))) - usage; - OCaml_current.Ast.make_top_mapper - ~signature:(fun sg -> - let config = initial_state () in - rewrite_signature config (module OCaml_current) sg - |> migrate_some_signature (module OCaml_current) - ) - ~structure:(fun str -> - let config = initial_state () in - rewrite_structure config (module OCaml_current) str - |> migrate_some_structure (module OCaml_current) - ) - end - -let protectx x ~finally ~f = - match f x with - | y -> finally x; y - | exception e -> finally x; raise e - -let with_file_in fn ~f = - protectx (open_in_bin fn) ~finally:close_in ~f - -let with_file_out fn ~f = - protectx (open_out_bin fn) ~finally:close_out ~f - -type ('a, 'b) intf_or_impl = - | Intf of 'a - | Impl of 'b - -type file_kind = - | Kind_intf - | Kind_impl - | Kind_unknown - -let guess_file_kind fn = - if Filename.check_suffix fn ".ml" then - Kind_impl - else if Filename.check_suffix fn ".mli" then - Kind_intf - else - Kind_unknown - -let check_kind fn ~expected ~got = - let describe = function - | Kind_intf -> "interface" - | Kind_impl -> "implementation" - | Kind_unknown -> "unknown file" - in - match expected, got with - | Kind_impl, Kind_impl - | Kind_intf, Kind_intf - | Kind_unknown, _ -> () - | _ -> - Location.raise_errorf ~loc:(Location.in_file fn) - "Expected an %s got an %s instead" - (describe expected) - (describe got) - -let load_file (kind, fn) = - with_file_in fn ~f:(fun ic -> - match Ast_io.from_channel ic with - | Ok (fn, Ast_io.Intf ((module V), sg)) -> - check_kind fn ~expected:kind ~got:Kind_intf; - Location.input_name := fn; - (* We need to convert to the current version in order to interpret the cookies using - [Ast_mapper.drop_ppx_context_*] from the compiler *) - let sg = (migrate (module V) (module OCaml_current)).copy_signature sg in - let migrate_back sg = - Ast_io.Intf - ((module V), - (migrate (module OCaml_current) (module V)).copy_signature sg) - in - (fn, Intf (sg, migrate_back)) - | Ok (fn, Ast_io.Impl ((module V), st)) -> - check_kind fn ~expected:kind ~got:Kind_impl; - Location.input_name := fn; - let st = (migrate (module V) (module OCaml_current)).copy_structure st in - let migrate_back st = - Ast_io.Impl - ((module V), - (migrate (module OCaml_current) (module V)).copy_structure st) - in - (fn, Impl (st, migrate_back)) - | Error (Ast_io.Unknown_version _) -> - Location.raise_errorf ~loc:(Location.in_file fn) - "File is a binary ast for an unknown version of OCaml" - | Error (Ast_io.Not_a_binary_ast prefix_read_from_file) -> - (* To test if a file is a binary AST file, we have to read the first few bytes of - the file. - - If it is not a binary AST, we have to parse these bytes and the rest of the file - as source code. To do that, we prefill the lexbuf buffer with what we read from - the file to do the test. *) - let lexbuf = Lexing.from_channel ic in - let len = String.length prefix_read_from_file in - String.blit prefix_read_from_file 0 lexbuf.Lexing.lex_buffer 0 len; - lexbuf.Lexing.lex_buffer_len <- len; - lexbuf.Lexing.lex_curr_p <- - { Lexing. - pos_fname = fn - ; pos_lnum = 1 - ; pos_bol = 0 - ; pos_cnum = 0 - }; - Location.input_name := fn; - let kind = - match kind with - | Kind_impl -> Kind_impl - | Kind_intf -> Kind_intf - | Kind_unknown -> guess_file_kind fn - in - match kind with - | Kind_impl -> - let migrate_back st = Ast_io.Impl ((module OCaml_current), st) in - (fn, Impl (Parse.implementation lexbuf, migrate_back)) - | Kind_intf -> - let migrate_back sg = Ast_io.Intf ((module OCaml_current), sg) in - (fn, Intf (Parse.interface lexbuf, migrate_back)) - | Kind_unknown -> - Location.raise_errorf ~loc:(Location.in_file fn) - "I can't decide whether %s is an implementation or interface file" - fn) - -let with_output ?bin output ~f = - match output with - | None -> - begin match bin with - | Some bin -> set_binary_mode_out stdout bin - | None -> () - end; - f stdout - | Some fn -> with_file_out fn ~f - -type output_mode = - | Pretty_print - | Dump_ast - | Null - -let process_file ~config ~output ~output_mode ~embed_errors file = - let fn, ast = load_file file in - let ast, binary_ast = - match ast with - | Intf (sg, migrate_back) -> - let sg = Ast_mapper.drop_ppx_context_sig ~restore:true sg in - let sg = - try - rewrite_signature config (module OCaml_current) sg - |> migrate_some_signature (module OCaml_current) - with exn when embed_errors -> - match Migrate_parsetree_compiler_functions.error_of_exn exn with - | None -> raise exn - | Some error -> - [ Ast_helper.Sig.extension ~loc:Location.none - (Ast_mapper.extension_of_error error) ] - in - let binary_sg = - Ast_mapper.add_ppx_context_sig ~tool_name:config.tool_name sg in - (Intf sg, migrate_back binary_sg) - | Impl (st, migrate_back) -> - let st = Ast_mapper.drop_ppx_context_str ~restore:true st in - let st = - try - rewrite_structure config (module OCaml_current) st - |> migrate_some_structure (module OCaml_current) - with exn when embed_errors -> - match Migrate_parsetree_compiler_functions.error_of_exn exn with - | None -> raise exn - | Some error -> - [ Ast_helper.Str.extension ~loc:Location.none - (Ast_mapper.extension_of_error error) ] - in - let binary_st = - Ast_mapper.add_ppx_context_str ~tool_name:config.tool_name st in - (Impl st, migrate_back binary_st) - in - match output_mode with - | Dump_ast -> - with_output ~bin:true output ~f:(fun oc -> - Ast_io.to_channel oc fn binary_ast) - | Pretty_print -> - with_output output ~f:(fun oc -> - let ppf = Format.formatter_of_out_channel oc in - (match ast with - | Intf sg -> Pprintast.signature ppf sg - | Impl st -> Pprintast.structure ppf st); - Format.pp_print_newline ppf ()) - | Null -> - () - -let print_transformations () = - let print_group name = function - | [] -> () - | names -> - Printf.printf "%s:\n" name; - List.iter (Printf.printf "%s\n") names - in - all_rewriters () - |> List.map rewriter_group_names - |> List.concat - |> print_group "Registered Transformations"; - Ppx_derivers.derivers () - |> List.map (fun (x, _) -> x) - |> print_group "Registered Derivers" - - -let run_as_standalone_driver ~exit_on_error argv = - let request_print_transformations = ref false in - let output = ref None in - let output_mode = ref Pretty_print in - let output_mode_arg = ref "" in - let files = ref [] in - let embed_errors = ref false in - let embed_errors_arg = ref "" in - let spec = - let fail fmt = Printf.ksprintf (fun s -> raise (Arg.Bad s)) fmt in - let incompatible a b = fail "%s and %s are incompatible" a b in - let as_ppx () = fail "--as-ppx must be passed as first argument" in - let set_embed_errors arg = - if !output_mode = Null then incompatible !output_mode_arg arg; - embed_errors := true; - embed_errors_arg := arg - in - let set_output_mode arg mode = - match !output_mode, mode with - | Pretty_print, _ -> - if mode = Null && !embed_errors then - incompatible !embed_errors_arg arg; - if mode = Null && !output <> None then - incompatible "-o" arg; - output_mode := mode; - output_mode_arg := arg - | _, Pretty_print -> assert false - | Dump_ast, Dump_ast | Null, Null -> () - | _ -> incompatible !output_mode_arg arg - in - let set_output fn = - if !output_mode = Null then incompatible !output_mode_arg "-o"; - output := Some fn - in - let as_pp () = - let arg = "--as-pp" in - set_output_mode arg Dump_ast; - set_embed_errors arg - in - [ "--as-ppx", Arg.Unit as_ppx, - " Act as a -ppx rewriter" - ; "--as-pp", Arg.Unit as_pp, - " Shorthand for: --dump-ast --embed-errors" - ; "--dump-ast", Arg.Unit (fun () -> set_output_mode "--dump-ast" Dump_ast), - " Output a binary AST instead of source code" - ; "--null", Arg.Unit (fun () -> set_output_mode "--null" Null), - " Output nothing, just report errors" - ; "-o", Arg.String set_output, - "FILE Output to this file instead of the standard output" - ; "--intf", Arg.String (fun fn -> files := (Kind_intf, fn) :: !files), - "FILE Treat FILE as a .mli file" - ; "--impl", Arg.String (fun fn -> files := (Kind_impl, fn) :: !files), - "FILE Treat FILE as a .ml file" - ; "--embed-errors", Arg.Unit (fun () -> set_embed_errors "--embed-errors"), - " Embed error reported by rewriters into the AST" - ; "--print-transformations", Arg.Set request_print_transformations, - " Print registered transformations in their order of executions" - ] - in - let spec = Arg.align (spec @ registered_args ()) in - let me = Filename.basename Sys.executable_name in - let usage = Printf.sprintf "%s [options] []" me in - exit_or_raise ~exit_on_error begin fun () -> - reset_args (); - Arg.parse_argv ~current:(ref 0) argv spec (fun anon -> - files := (Kind_unknown, anon) :: !files) usage; - if !request_print_transformations then - print_transformations () - else - let output = !output in - let output_mode = !output_mode in - let embed_errors = !embed_errors in - let config = - (* TODO: we could add -I, -L and -g options to populate these fields. *) - { tool_name = "migrate_driver" - ; include_dirs = [] - ; load_path = [] - ; debug = false - ; for_package = None - ; extras = [] - } - in - List.iter (process_file ~config ~output ~output_mode ~embed_errors) - (List.rev !files) - end - -let run_as_ppx_rewriter ?(exit_on_error = true) ?(argv = Sys.argv) () = - let a = argv in - let n = Array.length a in - exit_or_raise ~exit_on_error begin fun () -> - if n <= 2 then begin - let me = Filename.basename Sys.executable_name in - Arg.usage_string (registered_args ()) - (Printf.sprintf "%s [options] " me); - |> fun s -> raise (Arg.Bad s) - end; - Ast_mapper.apply ~source:a.(n - 2) ~target:a.(n - 1) - (run_as_ast_mapper (Array.to_list (Array.sub a 1 (n - 3)))) - end - -let run_main ?(exit_on_error = true) ?(argv = Sys.argv) () = - if Array.length argv >= 2 && argv.(1) = "--as-ppx" then - run_as_ppx_rewriter ~exit_on_error ~argv () - else - run_as_standalone_driver ~exit_on_error argv diff --git a/src/vendored-omp/src/migrate_parsetree_driver.mli b/src/vendored-omp/src/migrate_parsetree_driver.mli deleted file mode 100644 index 11a0bebfa..000000000 --- a/src/vendored-omp/src/migrate_parsetree_driver.mli +++ /dev/null @@ -1,113 +0,0 @@ -open Migrate_parsetree_versions - -(** {1 State a rewriter can access} *) - -type extra = .. - -type config = { - tool_name : string; - include_dirs : string list; - load_path : string list; - debug : bool; - for_package : string option; - (** Additional parameters that can be passed by a caller of - [rewrite_{signature,structure}] to a specific register rewriter. *) - extras : extra list; -} - -val make_config - : tool_name:string - -> ?include_dirs:string list - -> ?load_path:string list - -> ?debug:bool - -> ?for_package:string - -> ?extras:extra list - -> unit - -> config - -type cookies - -val get_cookie - : cookies - -> string - -> 'types ocaml_version -> 'types get_expression option - -val set_cookie - : cookies - -> string - -> 'types ocaml_version -> 'types get_expression - -> unit - -val set_global_cookie - : string - -> 'types ocaml_version -> 'types get_expression - -> unit - -(** {1 Registering rewriters} *) - -type 'types rewriter = config -> cookies -> 'types get_mapper - -(** Register a ppx rewriter. [position] is a integer that indicates - when the ppx rewriter should be applied. It is guaranteed that if - two ppx rewriters [a] and [b] have different position numbers, then - the one with the lowest number will be applied first. The rewriting - order of ppx rewriters with the same position number is not - specified. The default position is [0]. - - Note that more different position numbers means more AST - conversions and slower rewriting, so think twice before setting - [position] to a non-zero number. -*) -val register - : name:string - -> ?reset_args:(unit -> unit) -> ?args:(Arg.key * Arg.spec * Arg.doc) list - -> ?position:int - -> 'types ocaml_version -> 'types rewriter - -> unit - -(** Return the list of command line arguments registered by rewriters *) -val registered_args : unit -> (Arg.key * Arg.spec * Arg.doc) list - -(** Call all the registered [reset_args] callbacks *) -val reset_args : unit -> unit - -(** {1 Running registered rewriters} *) - -val run_as_ast_mapper : ?exit_on_error:bool -> string list -> Ast_mapper.mapper - -val run_as_ppx_rewriter : - ?exit_on_error:bool -> ?argv:string array -> unit -> unit - -val run_main : ?exit_on_error:bool -> ?argv:string array -> unit -> unit - -(** {1 Manual mapping} *) - -type some_signature = - | Sig : (module Migrate_parsetree_versions.OCaml_version with - type Ast.Parsetree.signature = 'concrete) * 'concrete -> some_signature - -type some_structure = - | Str : (module Migrate_parsetree_versions.OCaml_version with - type Ast.Parsetree.structure = 'concrete) * 'concrete -> some_structure - -val migrate_some_signature - : 'version ocaml_version - -> some_signature - -> 'version get_signature - -val migrate_some_structure - : 'version ocaml_version - -> some_structure - -> 'version get_structure - -val rewrite_signature - : config - -> 'version ocaml_version - -> 'version get_signature - -> some_signature - -val rewrite_structure - : config - -> 'version ocaml_version - -> 'version get_structure - -> some_structure diff --git a/src/vendored-omp/src/migrate_parsetree_parse.ml b/src/vendored-omp/src/migrate_parsetree_parse.ml deleted file mode 100644 index e2aef0d27..000000000 --- a/src/vendored-omp/src/migrate_parsetree_parse.ml +++ /dev/null @@ -1,53 +0,0 @@ - -(**************************************************************************) -(* *) -(* OCaml Migrate Parsetree *) -(* *) -(* Frédéric Bour *) -(* *) -(* Copyright 2017 Institut National de Recherche en Informatique et *) -(* en Automatique (INRIA). *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Parser entry points that migrate to a specified version of OCaml. - - The parser used is the one from current compiler-libs. The resulting AST is - then converted to the desired version. - - These parsing functions can raise Migration_errors. -*) - -open Migrate_parsetree_versions - -let implementation version = - let { copy_structure; _ } = migrate ocaml_current version in - fun lexbuf -> copy_structure (Parse.implementation lexbuf) - -let interface version = - let { copy_signature; _ } = migrate ocaml_current version in - fun lexbuf -> copy_signature (Parse.interface lexbuf) - -let toplevel_phrase version = - let { copy_toplevel_phrase; _ } = migrate ocaml_current version in - fun lexbuf -> copy_toplevel_phrase (Parse.toplevel_phrase lexbuf) - -let use_file version = - let { copy_toplevel_phrase; _ } = migrate ocaml_current version in - fun lexbuf -> List.map copy_toplevel_phrase (Parse.use_file lexbuf) - -let core_type version = - let { copy_core_type; _ } = migrate ocaml_current version in - fun lexbuf -> copy_core_type (Parse.core_type lexbuf) - -let expression version = - let { copy_expression; _ } = migrate ocaml_current version in - fun lexbuf -> copy_expression (Parse.expression lexbuf) - -let pattern version = - let { copy_pattern; _ } = migrate ocaml_current version in - fun lexbuf -> copy_pattern (Parse.pattern lexbuf) diff --git a/src/vendored-omp/src/migrate_parsetree_parse.mli b/src/vendored-omp/src/migrate_parsetree_parse.mli deleted file mode 100644 index 7d0ad48ad..000000000 --- a/src/vendored-omp/src/migrate_parsetree_parse.mli +++ /dev/null @@ -1,32 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml Migrate Parsetree *) -(* *) -(* Frédéric Bour *) -(* *) -(* Copyright 2017 Institut National de Recherche en Informatique et *) -(* en Automatique (INRIA). *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Parser entry points that migrate to a specified version of OCaml. - - The parser used is the one from current compiler-libs. The resulting AST is - then converted to the desired version. - - These parsing functions can raise Migration_errors. -*) - -open Migrate_parsetree_versions - -val implementation : 'types ocaml_version -> Lexing.lexbuf -> 'types get_structure -val interface : 'types ocaml_version -> Lexing.lexbuf -> 'types get_signature -val toplevel_phrase : 'types ocaml_version -> Lexing.lexbuf -> 'types get_toplevel_phrase -val use_file : 'types ocaml_version -> Lexing.lexbuf -> 'types get_toplevel_phrase list -val core_type : 'types ocaml_version -> Lexing.lexbuf -> 'types get_core_type -val expression : 'types ocaml_version -> Lexing.lexbuf -> 'types get_expression -val pattern : 'types ocaml_version -> Lexing.lexbuf -> 'types get_pattern diff --git a/src/vendored-omp/src/migrate_parsetree_versions.ml b/src/vendored-omp/src/migrate_parsetree_versions.ml index 36743eadc..239f033b9 100644 --- a/src/vendored-omp/src/migrate_parsetree_versions.ml +++ b/src/vendored-omp/src/migrate_parsetree_versions.ml @@ -35,18 +35,6 @@ module type Ast = sig printf "end\n" ) *) - module Parsetree : sig - type structure - type signature - type toplevel_phrase - type core_type - type expression - type pattern - type case - type type_declaration - type type_extension - type extension_constructor - end module Outcometree : sig type out_value type out_type @@ -56,21 +44,7 @@ module type Ast = sig type out_type_extension type out_phrase end - module Ast_mapper : sig - type mapper - end (*$*) - module Config : sig - val ast_impl_magic_number : string - val ast_intf_magic_number : string - end - val shallow_identity : Ast_mapper.mapper - val map_signature : Ast_mapper.mapper -> Parsetree.signature -> Parsetree.signature - val map_structure : Ast_mapper.mapper -> Parsetree.structure -> Parsetree.structure - val make_top_mapper - : signature:(Parsetree.signature -> Parsetree.signature) - -> structure:(Parsetree.structure -> Parsetree.structure) - -> Ast_mapper.mapper end (* Shortcuts for talking about ast types outside of the module language *) @@ -78,16 +52,6 @@ end type 'a _types = 'a constraint 'a = < (*$ foreach_type (fun _ s -> printf "%-21s : _;\n" s) *) - structure : _; - signature : _; - toplevel_phrase : _; - core_type : _; - expression : _; - pattern : _; - case : _; - type_declaration : _; - type_extension : _; - extension_constructor : _; out_value : _; out_type : _; out_class_type : _; @@ -95,7 +59,6 @@ type 'a _types = 'a constraint 'a out_sig_item : _; out_type_extension : _; out_phrase : _; - mapper : _; (*$*) > ;; @@ -104,26 +67,6 @@ type 'a _types = 'a constraint 'a printf "type 'a get_%s =\n" s; printf " 'x constraint 'a _types = < %s : 'x; .. >\n" s ) *) -type 'a get_structure = - 'x constraint 'a _types = < structure : 'x; .. > -type 'a get_signature = - 'x constraint 'a _types = < signature : 'x; .. > -type 'a get_toplevel_phrase = - 'x constraint 'a _types = < toplevel_phrase : 'x; .. > -type 'a get_core_type = - 'x constraint 'a _types = < core_type : 'x; .. > -type 'a get_expression = - 'x constraint 'a _types = < expression : 'x; .. > -type 'a get_pattern = - 'x constraint 'a _types = < pattern : 'x; .. > -type 'a get_case = - 'x constraint 'a _types = < case : 'x; .. > -type 'a get_type_declaration = - 'x constraint 'a _types = < type_declaration : 'x; .. > -type 'a get_type_extension = - 'x constraint 'a _types = < type_extension : 'x; .. > -type 'a get_extension_constructor = - 'x constraint 'a _types = < extension_constructor : 'x; .. > type 'a get_out_value = 'x constraint 'a _types = < out_value : 'x; .. > type 'a get_out_type = @@ -138,8 +81,6 @@ type 'a get_out_type_extension = 'x constraint 'a _types = < out_type_extension : 'x; .. > type 'a get_out_phrase = 'x constraint 'a _types = < out_phrase : 'x; .. > -type 'a get_mapper = - 'x constraint 'a _types = < mapper : 'x; .. > (*$*) module type OCaml_version = sig @@ -148,16 +89,6 @@ module type OCaml_version = sig val string_version : string type types = < (*$ foreach_type (fun m s -> printf "%-21s : Ast.%s.%s;\n" s m s)*) - structure : Ast.Parsetree.structure; - signature : Ast.Parsetree.signature; - toplevel_phrase : Ast.Parsetree.toplevel_phrase; - core_type : Ast.Parsetree.core_type; - expression : Ast.Parsetree.expression; - pattern : Ast.Parsetree.pattern; - case : Ast.Parsetree.case; - type_declaration : Ast.Parsetree.type_declaration; - type_extension : Ast.Parsetree.type_extension; - extension_constructor : Ast.Parsetree.extension_constructor; out_value : Ast.Outcometree.out_value; out_type : Ast.Outcometree.out_type; out_class_type : Ast.Outcometree.out_class_type; @@ -165,7 +96,6 @@ module type OCaml_version = sig out_sig_item : Ast.Outcometree.out_sig_item; out_type_extension : Ast.Outcometree.out_type_extension; out_phrase : Ast.Outcometree.out_phrase; - mapper : Ast.Ast_mapper.mapper; (*$*) > _types type _ witnesses += Version : types witnesses @@ -176,16 +106,6 @@ module Make_witness(Ast : Ast) = struct type types = < (*$ foreach_type (fun m s -> printf "%-21s : Ast.%s.%s;\n" s m s)*) - structure : Ast.Parsetree.structure; - signature : Ast.Parsetree.signature; - toplevel_phrase : Ast.Parsetree.toplevel_phrase; - core_type : Ast.Parsetree.core_type; - expression : Ast.Parsetree.expression; - pattern : Ast.Parsetree.pattern; - case : Ast.Parsetree.case; - type_declaration : Ast.Parsetree.type_declaration; - type_extension : Ast.Parsetree.type_extension; - extension_constructor : Ast.Parsetree.extension_constructor; out_value : Ast.Outcometree.out_value; out_type : Ast.Outcometree.out_type; out_class_type : Ast.Outcometree.out_class_type; @@ -193,7 +113,6 @@ struct out_sig_item : Ast.Outcometree.out_sig_item; out_type_extension : Ast.Outcometree.out_type_extension; out_phrase : Ast.Outcometree.out_phrase; - mapper : Ast.Ast_mapper.mapper; (*$*) > _types type _ witnesses += Version : types witnesses @@ -206,24 +125,13 @@ type 'types ocaml_version = (*$ let sep = with_then_and () in foreach_type (fun m s -> printf "%t type Ast.%s.%s = 'types get_%s\n" sep m s s) *) - with type Ast.Parsetree.structure = 'types get_structure - and type Ast.Parsetree.signature = 'types get_signature - and type Ast.Parsetree.toplevel_phrase = 'types get_toplevel_phrase - and type Ast.Parsetree.core_type = 'types get_core_type - and type Ast.Parsetree.expression = 'types get_expression - and type Ast.Parsetree.pattern = 'types get_pattern - and type Ast.Parsetree.case = 'types get_case - and type Ast.Parsetree.type_declaration = 'types get_type_declaration - and type Ast.Parsetree.type_extension = 'types get_type_extension - and type Ast.Parsetree.extension_constructor = 'types get_extension_constructor - and type Ast.Outcometree.out_value = 'types get_out_value + with type Ast.Outcometree.out_value = 'types get_out_value and type Ast.Outcometree.out_type = 'types get_out_type and type Ast.Outcometree.out_class_type = 'types get_out_class_type and type Ast.Outcometree.out_module_type = 'types get_out_module_type and type Ast.Outcometree.out_sig_item = 'types get_out_sig_item and type Ast.Outcometree.out_type_extension = 'types get_out_type_extension and type Ast.Outcometree.out_phrase = 'types get_out_phrase - and type Ast.Ast_mapper.mapper = 'types get_mapper (*$*) ) @@ -234,16 +142,6 @@ type ('a, 'b) type_comparison = let compare_ocaml_version (*$ foreach_type (fun _ s -> printf "(type %s1) (type %s2)\n" s s) *) - (type structure1) (type structure2) - (type signature1) (type signature2) - (type toplevel_phrase1) (type toplevel_phrase2) - (type core_type1) (type core_type2) - (type expression1) (type expression2) - (type pattern1) (type pattern2) - (type case1) (type case2) - (type type_declaration1) (type type_declaration2) - (type type_extension1) (type type_extension2) - (type extension_constructor1) (type extension_constructor2) (type out_value1) (type out_value2) (type out_type1) (type out_type2) (type out_class_type1) (type out_class_type2) @@ -251,20 +149,9 @@ let compare_ocaml_version (type out_sig_item1) (type out_sig_item2) (type out_type_extension1) (type out_type_extension2) (type out_phrase1) (type out_phrase2) - (type mapper1) (type mapper2) (*$*) ((module A) : < (*$ foreach_type (fun _ s -> printf "%-21s : %s1;\n" s s) *) - structure : structure1; - signature : signature1; - toplevel_phrase : toplevel_phrase1; - core_type : core_type1; - expression : expression1; - pattern : pattern1; - case : case1; - type_declaration : type_declaration1; - type_extension : type_extension1; - extension_constructor : extension_constructor1; out_value : out_value1; out_type : out_type1; out_class_type : out_class_type1; @@ -272,21 +159,10 @@ let compare_ocaml_version out_sig_item : out_sig_item1; out_type_extension : out_type_extension1; out_phrase : out_phrase1; - mapper : mapper1; (*$*) > ocaml_version) ((module B) : < (*$ foreach_type (fun _ s -> printf "%-21s : %s2;\n" s s) *) - structure : structure2; - signature : signature2; - toplevel_phrase : toplevel_phrase2; - core_type : core_type2; - expression : expression2; - pattern : pattern2; - case : case2; - type_declaration : type_declaration2; - type_extension : type_extension2; - extension_constructor : extension_constructor2; out_value : out_value2; out_type : out_type2; out_class_type : out_class_type2; @@ -294,7 +170,6 @@ let compare_ocaml_version out_sig_item : out_sig_item2; out_type_extension : out_type_extension2; out_phrase : out_phrase2; - mapper : mapper2; (*$*) > ocaml_version) : (A.types, B.types) type_comparison @@ -308,16 +183,6 @@ let compare_ocaml_version type ('from, 'to_) migration_functions = { (*$ foreach_type (fun _ s -> printf "copy_%s: 'from get_%s -> 'to_ get_%s;\n" s s s) *) - copy_structure: 'from get_structure -> 'to_ get_structure; - copy_signature: 'from get_signature -> 'to_ get_signature; - copy_toplevel_phrase: 'from get_toplevel_phrase -> 'to_ get_toplevel_phrase; - copy_core_type: 'from get_core_type -> 'to_ get_core_type; - copy_expression: 'from get_expression -> 'to_ get_expression; - copy_pattern: 'from get_pattern -> 'to_ get_pattern; - copy_case: 'from get_case -> 'to_ get_case; - copy_type_declaration: 'from get_type_declaration -> 'to_ get_type_declaration; - copy_type_extension: 'from get_type_extension -> 'to_ get_type_extension; - copy_extension_constructor: 'from get_extension_constructor -> 'to_ get_extension_constructor; copy_out_value: 'from get_out_value -> 'to_ get_out_value; copy_out_type: 'from get_out_type -> 'to_ get_out_type; copy_out_class_type: 'from get_out_class_type -> 'to_ get_out_class_type; @@ -325,23 +190,12 @@ type ('from, 'to_) migration_functions = { copy_out_sig_item: 'from get_out_sig_item -> 'to_ get_out_sig_item; copy_out_type_extension: 'from get_out_type_extension -> 'to_ get_out_type_extension; copy_out_phrase: 'from get_out_phrase -> 'to_ get_out_phrase; - copy_mapper: 'from get_mapper -> 'to_ get_mapper; (*$*) } let id x = x let migration_identity : ('a, 'a) migration_functions = { (*$ foreach_type (fun _ s -> printf "copy_%s = id;\n" s) *) - copy_structure = id; - copy_signature = id; - copy_toplevel_phrase = id; - copy_core_type = id; - copy_expression = id; - copy_pattern = id; - copy_case = id; - copy_type_declaration = id; - copy_type_extension = id; - copy_extension_constructor = id; copy_out_value = id; copy_out_type = id; copy_out_class_type = id; @@ -349,7 +203,6 @@ let migration_identity : ('a, 'a) migration_functions = { copy_out_sig_item = id; copy_out_type_extension = id; copy_out_phrase = id; - copy_mapper = id; (*$*) } @@ -357,16 +210,6 @@ let compose f g x = f (g x) let migration_compose (ab : ('a, 'b) migration_functions) (bc : ('b, 'c) migration_functions) : ('a, 'c) migration_functions = { (*$ foreach_type (fun _ s -> printf "copy_%-21s = compose bc.copy_%-21s ab.copy_%s;\n" s s s) *) - copy_structure = compose bc.copy_structure ab.copy_structure; - copy_signature = compose bc.copy_signature ab.copy_signature; - copy_toplevel_phrase = compose bc.copy_toplevel_phrase ab.copy_toplevel_phrase; - copy_core_type = compose bc.copy_core_type ab.copy_core_type; - copy_expression = compose bc.copy_expression ab.copy_expression; - copy_pattern = compose bc.copy_pattern ab.copy_pattern; - copy_case = compose bc.copy_case ab.copy_case; - copy_type_declaration = compose bc.copy_type_declaration ab.copy_type_declaration; - copy_type_extension = compose bc.copy_type_extension ab.copy_type_extension; - copy_extension_constructor = compose bc.copy_extension_constructor ab.copy_extension_constructor; copy_out_value = compose bc.copy_out_value ab.copy_out_value; copy_out_type = compose bc.copy_out_type ab.copy_out_type; copy_out_class_type = compose bc.copy_out_class_type ab.copy_out_class_type; @@ -374,7 +217,6 @@ let migration_compose (ab : ('a, 'b) migration_functions) (bc : ('b, 'c) migrati copy_out_sig_item = compose bc.copy_out_sig_item ab.copy_out_sig_item; copy_out_type_extension = compose bc.copy_out_type_extension ab.copy_out_type_extension; copy_out_phrase = compose bc.copy_out_phrase ab.copy_out_phrase; - copy_mapper = compose bc.copy_mapper ab.copy_mapper; (*$*) } @@ -385,16 +227,6 @@ module type Migrate_module = sig module To : Ast (*$ foreach_type (fun m s -> printf "val copy_%-21s: From.%s.%s -> To.%s.%s\n" s m s m s) *) - val copy_structure : From.Parsetree.structure -> To.Parsetree.structure - val copy_signature : From.Parsetree.signature -> To.Parsetree.signature - val copy_toplevel_phrase : From.Parsetree.toplevel_phrase -> To.Parsetree.toplevel_phrase - val copy_core_type : From.Parsetree.core_type -> To.Parsetree.core_type - val copy_expression : From.Parsetree.expression -> To.Parsetree.expression - val copy_pattern : From.Parsetree.pattern -> To.Parsetree.pattern - val copy_case : From.Parsetree.case -> To.Parsetree.case - val copy_type_declaration : From.Parsetree.type_declaration -> To.Parsetree.type_declaration - val copy_type_extension : From.Parsetree.type_extension -> To.Parsetree.type_extension - val copy_extension_constructor: From.Parsetree.extension_constructor -> To.Parsetree.extension_constructor val copy_out_value : From.Outcometree.out_value -> To.Outcometree.out_value val copy_out_type : From.Outcometree.out_type -> To.Outcometree.out_type val copy_out_class_type : From.Outcometree.out_class_type -> To.Outcometree.out_class_type @@ -402,7 +234,6 @@ module type Migrate_module = sig val copy_out_sig_item : From.Outcometree.out_sig_item -> To.Outcometree.out_sig_item val copy_out_type_extension : From.Outcometree.out_type_extension -> To.Outcometree.out_type_extension val copy_out_phrase : From.Outcometree.out_phrase -> To.Outcometree.out_phrase - val copy_mapper : From.Ast_mapper.mapper -> To.Ast_mapper.mapper (*$*) end @@ -415,16 +246,6 @@ struct let open A_to_B in { (*$ foreach_type (fun _ s -> printf "copy_%s;\n" s) *) - copy_structure; - copy_signature; - copy_toplevel_phrase; - copy_core_type; - copy_expression; - copy_pattern; - copy_case; - copy_type_declaration; - copy_type_extension; - copy_extension_constructor; copy_out_value; copy_out_type; copy_out_class_type; @@ -432,7 +253,6 @@ struct copy_out_sig_item; copy_out_type_extension; copy_out_phrase; - copy_mapper; (*$*) } end @@ -467,16 +287,6 @@ type 'from immediate_migration = let immediate_migration (*$ foreach_type (fun _ s -> printf "(type %s)\n" s) *) - (type structure) - (type signature) - (type toplevel_phrase) - (type core_type) - (type expression) - (type pattern) - (type case) - (type type_declaration) - (type type_extension) - (type extension_constructor) (type out_value) (type out_type) (type out_class_type) @@ -484,20 +294,9 @@ let immediate_migration (type out_sig_item) (type out_type_extension) (type out_phrase) - (type mapper) (*$*) ((module A) : < (*$ foreach_type (fun _ s -> printf "%-21s : %s;\n" s s) *) - structure : structure; - signature : signature; - toplevel_phrase : toplevel_phrase; - core_type : core_type; - expression : expression; - pattern : pattern; - case : case; - type_declaration : type_declaration; - type_extension : type_extension; - extension_constructor : extension_constructor; out_value : out_value; out_type : out_type; out_class_type : out_class_type; @@ -505,7 +304,6 @@ let immediate_migration out_sig_item : out_sig_item; out_type_extension : out_type_extension; out_phrase : out_phrase; - mapper : mapper; (*$*) > ocaml_version) direction @@ -521,16 +319,6 @@ let immediate_migration let migrate (*$ foreach_type (fun _ s -> printf "(type %s1) (type %s2)\n" s s) *) - (type structure1) (type structure2) - (type signature1) (type signature2) - (type toplevel_phrase1) (type toplevel_phrase2) - (type core_type1) (type core_type2) - (type expression1) (type expression2) - (type pattern1) (type pattern2) - (type case1) (type case2) - (type type_declaration1) (type type_declaration2) - (type type_extension1) (type type_extension2) - (type extension_constructor1) (type extension_constructor2) (type out_value1) (type out_value2) (type out_type1) (type out_type2) (type out_class_type1) (type out_class_type2) @@ -538,20 +326,9 @@ let migrate (type out_sig_item1) (type out_sig_item2) (type out_type_extension1) (type out_type_extension2) (type out_phrase1) (type out_phrase2) - (type mapper1) (type mapper2) (*$*) ((module A) : < (*$ foreach_type (fun _ s -> printf "%-21s : %s1;\n" s s) *) - structure : structure1; - signature : signature1; - toplevel_phrase : toplevel_phrase1; - core_type : core_type1; - expression : expression1; - pattern : pattern1; - case : case1; - type_declaration : type_declaration1; - type_extension : type_extension1; - extension_constructor : extension_constructor1; out_value : out_value1; out_type : out_type1; out_class_type : out_class_type1; @@ -559,21 +336,10 @@ let migrate out_sig_item : out_sig_item1; out_type_extension : out_type_extension1; out_phrase : out_phrase1; - mapper : mapper1; (*$*) > ocaml_version) ((module B) : < (*$ foreach_type (fun _ s -> printf "%-21s : %s2;\n" s s) *) - structure : structure2; - signature : signature2; - toplevel_phrase : toplevel_phrase2; - core_type : core_type2; - expression : expression2; - pattern : pattern2; - case : case2; - type_declaration : type_declaration2; - type_extension : type_extension2; - extension_constructor : extension_constructor2; out_value : out_value2; out_type : out_type2; out_class_type : out_class_type2; @@ -581,7 +347,6 @@ let migrate out_sig_item : out_sig_item2; out_type_extension : out_type_extension2; out_phrase : out_phrase2; - mapper : mapper2; (*$*) > ocaml_version) : (A.types, B.types) migration_functions @@ -607,16 +372,6 @@ let migrate module Convert (A : OCaml_version) (B : OCaml_version) = struct let { (*$ foreach_type (fun _ s -> printf "copy_%s;\n" s) *) - copy_structure; - copy_signature; - copy_toplevel_phrase; - copy_core_type; - copy_expression; - copy_pattern; - copy_case; - copy_type_declaration; - copy_type_extension; - copy_extension_constructor; copy_out_value; copy_out_type; copy_out_class_type; @@ -624,7 +379,6 @@ module Convert (A : OCaml_version) (B : OCaml_version) = struct copy_out_sig_item; copy_out_type_extension; copy_out_phrase; - copy_mapper; (*$*) } : (A.types, B.types) migration_functions = migrate (module A) (module B) @@ -798,4 +552,4 @@ module OCaml_current = OCaml_OCAML_VERSION let ocaml_current : OCaml_current.types ocaml_version = (module OCaml_current) (* Make sure the preprocessing worked as expected *) -let _f (x : Parsetree.expression) : OCaml_current.Ast.Parsetree.expression = x +let _f (x : Outcometree.out_type) : OCaml_current.Ast.Outcometree.out_type = x diff --git a/src/vendored-omp/src/migrate_parsetree_versions.mli b/src/vendored-omp/src/migrate_parsetree_versions.mli index b31f6888c..e7c5e105f 100644 --- a/src/vendored-omp/src/migrate_parsetree_versions.mli +++ b/src/vendored-omp/src/migrate_parsetree_versions.mli @@ -26,18 +26,6 @@ module type Ast = sig printf "end\n" ) *) - module Parsetree : sig - type structure - type signature - type toplevel_phrase - type core_type - type expression - type pattern - type case - type type_declaration - type type_extension - type extension_constructor - end module Outcometree : sig type out_value type out_type @@ -47,21 +35,7 @@ module type Ast = sig type out_type_extension type out_phrase end - module Ast_mapper : sig - type mapper - end (*$*) - module Config : sig - val ast_impl_magic_number : string - val ast_intf_magic_number : string - end - val shallow_identity : Ast_mapper.mapper - val map_signature : Ast_mapper.mapper -> Parsetree.signature -> Parsetree.signature - val map_structure : Ast_mapper.mapper -> Parsetree.structure -> Parsetree.structure - val make_top_mapper - : signature:(Parsetree.signature -> Parsetree.signature) - -> structure:(Parsetree.structure -> Parsetree.structure) - -> Ast_mapper.mapper end (* Shortcuts for talking about ast types outside of the module language *) @@ -69,16 +43,6 @@ end type 'a _types = 'a constraint 'a = < (*$ foreach_type (fun _ s -> printf "%-21s : _;\n" s) *) - structure : _; - signature : _; - toplevel_phrase : _; - core_type : _; - expression : _; - pattern : _; - case : _; - type_declaration : _; - type_extension : _; - extension_constructor : _; out_value : _; out_type : _; out_class_type : _; @@ -86,7 +50,6 @@ type 'a _types = 'a constraint 'a out_sig_item : _; out_type_extension : _; out_phrase : _; - mapper : _; (*$*) > ;; @@ -95,16 +58,6 @@ type 'a _types = 'a constraint 'a printf "type 'a get_%s = 'x constraint 'a _types = < %s : 'x; .. >\n" s s ); printf ";;\n" *) -type 'a get_structure = 'x constraint 'a _types = < structure : 'x; .. > -type 'a get_signature = 'x constraint 'a _types = < signature : 'x; .. > -type 'a get_toplevel_phrase = 'x constraint 'a _types = < toplevel_phrase : 'x; .. > -type 'a get_core_type = 'x constraint 'a _types = < core_type : 'x; .. > -type 'a get_expression = 'x constraint 'a _types = < expression : 'x; .. > -type 'a get_pattern = 'x constraint 'a _types = < pattern : 'x; .. > -type 'a get_case = 'x constraint 'a _types = < case : 'x; .. > -type 'a get_type_declaration = 'x constraint 'a _types = < type_declaration : 'x; .. > -type 'a get_type_extension = 'x constraint 'a _types = < type_extension : 'x; .. > -type 'a get_extension_constructor = 'x constraint 'a _types = < extension_constructor : 'x; .. > type 'a get_out_value = 'x constraint 'a _types = < out_value : 'x; .. > type 'a get_out_type = 'x constraint 'a _types = < out_type : 'x; .. > type 'a get_out_class_type = 'x constraint 'a _types = < out_class_type : 'x; .. > @@ -112,7 +65,6 @@ type 'a get_out_module_type = 'x constraint 'a _types = < out_module_type : 'x; type 'a get_out_sig_item = 'x constraint 'a _types = < out_sig_item : 'x; .. > type 'a get_out_type_extension = 'x constraint 'a _types = < out_type_extension : 'x; .. > type 'a get_out_phrase = 'x constraint 'a _types = < out_phrase : 'x; .. > -type 'a get_mapper = 'x constraint 'a _types = < mapper : 'x; .. > ;; (*$*) @@ -140,16 +92,6 @@ module type OCaml_version = sig (** Shortcut for talking about Ast types *) type types = < (*$ foreach_type (fun m s -> printf "%-21s : Ast.%s.%s;\n" s m s) *) - structure : Ast.Parsetree.structure; - signature : Ast.Parsetree.signature; - toplevel_phrase : Ast.Parsetree.toplevel_phrase; - core_type : Ast.Parsetree.core_type; - expression : Ast.Parsetree.expression; - pattern : Ast.Parsetree.pattern; - case : Ast.Parsetree.case; - type_declaration : Ast.Parsetree.type_declaration; - type_extension : Ast.Parsetree.type_extension; - extension_constructor : Ast.Parsetree.extension_constructor; out_value : Ast.Outcometree.out_value; out_type : Ast.Outcometree.out_type; out_class_type : Ast.Outcometree.out_class_type; @@ -157,7 +99,6 @@ module type OCaml_version = sig out_sig_item : Ast.Outcometree.out_sig_item; out_type_extension : Ast.Outcometree.out_type_extension; out_phrase : Ast.Outcometree.out_phrase; - mapper : Ast.Ast_mapper.mapper; (*$*) > _types @@ -175,24 +116,13 @@ type 'types ocaml_version = (*$ let sep = with_then_and () in foreach_type (fun m s -> printf "%t type Ast.%s.%s = 'types get_%s\n" sep m s s) *) - with type Ast.Parsetree.structure = 'types get_structure - and type Ast.Parsetree.signature = 'types get_signature - and type Ast.Parsetree.toplevel_phrase = 'types get_toplevel_phrase - and type Ast.Parsetree.core_type = 'types get_core_type - and type Ast.Parsetree.expression = 'types get_expression - and type Ast.Parsetree.pattern = 'types get_pattern - and type Ast.Parsetree.case = 'types get_case - and type Ast.Parsetree.type_declaration = 'types get_type_declaration - and type Ast.Parsetree.type_extension = 'types get_type_extension - and type Ast.Parsetree.extension_constructor = 'types get_extension_constructor - and type Ast.Outcometree.out_value = 'types get_out_value + with type Ast.Outcometree.out_value = 'types get_out_value and type Ast.Outcometree.out_type = 'types get_out_type and type Ast.Outcometree.out_class_type = 'types get_out_class_type and type Ast.Outcometree.out_module_type = 'types get_out_module_type and type Ast.Outcometree.out_sig_item = 'types get_out_sig_item and type Ast.Outcometree.out_type_extension = 'types get_out_type_extension and type Ast.Outcometree.out_phrase = 'types get_out_phrase - and type Ast.Ast_mapper.mapper = 'types get_mapper (*$*) ) @@ -252,16 +182,6 @@ val compare_ocaml_version : 'a ocaml_version -> 'b ocaml_version -> ('a, 'b) typ type ('from, 'to_) migration_functions = { (*$ foreach_type (fun _ s -> printf "copy_%s: 'from get_%s -> 'to_ get_%s;\n" s s s) *) - copy_structure: 'from get_structure -> 'to_ get_structure; - copy_signature: 'from get_signature -> 'to_ get_signature; - copy_toplevel_phrase: 'from get_toplevel_phrase -> 'to_ get_toplevel_phrase; - copy_core_type: 'from get_core_type -> 'to_ get_core_type; - copy_expression: 'from get_expression -> 'to_ get_expression; - copy_pattern: 'from get_pattern -> 'to_ get_pattern; - copy_case: 'from get_case -> 'to_ get_case; - copy_type_declaration: 'from get_type_declaration -> 'to_ get_type_declaration; - copy_type_extension: 'from get_type_extension -> 'to_ get_type_extension; - copy_extension_constructor: 'from get_extension_constructor -> 'to_ get_extension_constructor; copy_out_value: 'from get_out_value -> 'to_ get_out_value; copy_out_type: 'from get_out_type -> 'to_ get_out_type; copy_out_class_type: 'from get_out_class_type -> 'to_ get_out_class_type; @@ -269,7 +189,6 @@ type ('from, 'to_) migration_functions = { copy_out_sig_item: 'from get_out_sig_item -> 'to_ get_out_sig_item; copy_out_type_extension: 'from get_out_type_extension -> 'to_ get_out_type_extension; copy_out_phrase: 'from get_out_phrase -> 'to_ get_out_phrase; - copy_mapper: 'from get_mapper -> 'to_ get_mapper; (*$*) } @@ -300,16 +219,6 @@ module Convert (A : OCaml_version) (B : OCaml_version) : sig (*$ foreach_type (fun m s -> let fq = sprintf "%s.%s" m s in printf " val copy_%-21s : A.Ast.%-31s -> B.Ast.%s\n" s fq fq) *) - val copy_structure : A.Ast.Parsetree.structure -> B.Ast.Parsetree.structure - val copy_signature : A.Ast.Parsetree.signature -> B.Ast.Parsetree.signature - val copy_toplevel_phrase : A.Ast.Parsetree.toplevel_phrase -> B.Ast.Parsetree.toplevel_phrase - val copy_core_type : A.Ast.Parsetree.core_type -> B.Ast.Parsetree.core_type - val copy_expression : A.Ast.Parsetree.expression -> B.Ast.Parsetree.expression - val copy_pattern : A.Ast.Parsetree.pattern -> B.Ast.Parsetree.pattern - val copy_case : A.Ast.Parsetree.case -> B.Ast.Parsetree.case - val copy_type_declaration : A.Ast.Parsetree.type_declaration -> B.Ast.Parsetree.type_declaration - val copy_type_extension : A.Ast.Parsetree.type_extension -> B.Ast.Parsetree.type_extension - val copy_extension_constructor : A.Ast.Parsetree.extension_constructor -> B.Ast.Parsetree.extension_constructor val copy_out_value : A.Ast.Outcometree.out_value -> B.Ast.Outcometree.out_value val copy_out_type : A.Ast.Outcometree.out_type -> B.Ast.Outcometree.out_type val copy_out_class_type : A.Ast.Outcometree.out_class_type -> B.Ast.Outcometree.out_class_type @@ -317,6 +226,5 @@ module Convert (A : OCaml_version) (B : OCaml_version) : sig val copy_out_sig_item : A.Ast.Outcometree.out_sig_item -> B.Ast.Outcometree.out_sig_item val copy_out_type_extension : A.Ast.Outcometree.out_type_extension -> B.Ast.Outcometree.out_type_extension val copy_out_phrase : A.Ast.Outcometree.out_phrase -> B.Ast.Outcometree.out_phrase - val copy_mapper : A.Ast.Ast_mapper.mapper -> B.Ast.Ast_mapper.mapper (*$*) end diff --git a/src/vendored-omp/src/reason_omp.ml b/src/vendored-omp/src/reason_omp.ml index dac4f478b..c7e58d2e4 100644 --- a/src/vendored-omp/src/reason_omp.ml +++ b/src/vendored-omp/src/reason_omp.ml @@ -40,9 +40,6 @@ module Ast_414 = Ast_414 module Ast_500 = Ast_500 (*$*) -(* A module for marshalling/unmarshalling arbitrary versions of Asts *) -module Ast_io = Migrate_parsetree_ast_io - (* Manual migration between versions *) (*$foreach_version_pair (fun x y -> printf "module Migrate_%s_%s = Migrate_parsetree_%s_%s\n" x y x y; @@ -106,12 +103,6 @@ module OCaml_current = Versions.OCaml_current migrating from one to the other. *) module Convert = Versions.Convert -(* A [Parse] module that migrate ASTs to the desired version of an AST *) -module Parse = Migrate_parsetree_parse - -(* Entrypoints for registering rewriters and making a ppx binary *) -module Driver = Migrate_parsetree_driver - (* Aliases for compiler-libs modules that might be shadowed *) module Compiler_libs = struct module Location = Location diff --git a/src/vendored-omp/tools/dune b/src/vendored-omp/tools/dune index af40a159e..8122ac6b4 100644 --- a/src/vendored-omp/tools/dune +++ b/src/vendored-omp/tools/dune @@ -3,11 +3,8 @@ (modules add_special_comments) (libraries compiler-libs.common compiler-libs.bytecomp) (flags :standard -w -3) - (enabled_if - (and - (>= %{ocaml_version} 4.13) - (< %{ocaml_version} 4.14)))) - + (enabled_if + (>= %{ocaml_version} 4.13))) (executables (names pp) @@ -21,8 +18,7 @@ (name gencopy) (enabled_if (and - (>= %{ocaml_version} 4.13) - (< %{ocaml_version} 4.14))) + (>= %{ocaml_version} 5.0))) (modules gencopy) (libraries compiler-libs.common compiler-libs.bytecomp) (flags :standard -w -3)) diff --git a/src/vendored-omp/tools/gencopy.ml b/src/vendored-omp/tools/gencopy.ml index f821c6d8e..4e2684722 100644 --- a/src/vendored-omp/tools/gencopy.ml +++ b/src/vendored-omp/tools/gencopy.ml @@ -82,7 +82,7 @@ module Main : sig end = struct (*************************************************************************) - let env = Env.initial_safe_string + let env = Env.initial let module_mapping = ref [] @@ -144,7 +144,7 @@ module Main : sig end = struct td.type_params in let env = - List.map2 (fun s t -> (t.id, evar s.txt)) params_in td.type_params + List.map2 (fun s t -> (Types.get_id t, evar s.txt)) params_in td.type_params in let make_result_t tyargs_in tyargs_out = Typ.( @@ -212,9 +212,9 @@ module Main : sig end = struct List.split (List.mapi arg tl) and tyexpr env ty x = - match ty.desc with + match Types.get_desc ty with | Tvar _ -> ( - match List.assoc ty.id env with + match List.assoc (Types.get_id ty) env with | f -> app f [ x ] | exception Not_found -> failwith "Existentials not supported" ) | Ttuple tl -> @@ -312,7 +312,7 @@ module Main : sig end = struct let usage = Printf.sprintf "%s [options] \n" Sys.argv.(0) let main () = - Load_path.init [ Config.standard_library ]; + Load_path.init ~auto_include:Compmisc.auto_include [ Config.standard_library ]; Arg.parse (Arg.align args) gen usage; let from_, to_ = match !module_mapping with @@ -341,3 +341,11 @@ module Main : sig end = struct Format.eprintf "%a@?" Errors.report_error exn; exit 1 end + +(* ../../_build/default/src/vendored-omp/tools/gencopy.exe -I . -I src/ -I +compiler-libs -map Ast_403:Ast_402 Ast_403.Outcometree.{out_phrase,out_type_extension} > src/migrate_parsetree_403_402_migrate.ml *) +(* ../../_build/default/src/vendored-omp/tools/gencopy.exe -I . -I src/ -I +compiler-libs -map Ast_402:Ast_403 Ast_402.Outcometree.{out_phrase,out_type_extension} > src/migrate_parsetree_402_403_migrate.ml *) + + +(* ../../_build/default/src/vendored-omp/tools/gencopy.exe -I . -I src/ -I +compiler-libs -map Ast_500:Ast_414 Ast_500.Outcometree.{out_phrase,out_type_extension} > src/migrate_parsetree_500_414_migrate.ml *) +(* ../../_build/default/src/vendored-omp/tools/gencopy.exe -I . -I src/ -I +compiler-libs -map Ast_414:Ast_500 Ast_414.Outcometree.{out_phrase,out_type_extension} > src/migrate_parsetree_414_500_migrate.ml *) + diff --git a/test/basics.t/run.t b/test/basics.t/run.t index df08f6c0b..14913bf7e 100644 --- a/test/basics.t/run.t +++ b/test/basics.t/run.t @@ -1,5 +1,6 @@ Format basic $ refmt --print re ./input.re > ./formatted.re +$ cat formatted.re Type-check basics $ ocamlc -c -pp 'refmt --print binary' -intf-suffix .rei -impl formatted.re diff --git a/test/lib/typedtreePrinter.cppo.ml b/test/lib/typedtreePrinter.cppo.ml index 00cc7ade4..233c2deb4 100644 --- a/test/lib/typedtreePrinter.cppo.ml +++ b/test/lib/typedtreePrinter.cppo.ml @@ -20,9 +20,9 @@ *) open Reason_omp +module Ast = Ast_414 -module Convert = Reason_omp.Convert (Reason_omp.OCaml_411) (Reason_omp.OCaml_current) -module ConvertBack = Reason_omp.Convert (Reason_omp.OCaml_current) (Reason_omp.OCaml_411) +module ConvertBack = Reason_omp.Convert (Reason_omp.OCaml_current) (Reason_omp.OCaml_414) let main () = let filename = "./TestTest.ml" in @@ -39,7 +39,7 @@ let main () = Env.set_unit_name modulename; let ast = impl lexbuf in - let ast = Convert.copy_structure ast in + let ast = Reason_toolchain.To_current.copy_structure ast in let env = Compmisc.initial_env() in #if OCAML_VERSION >= (4,13,0) let { Typedtree.structure = typedtree; _ } = @@ -48,7 +48,7 @@ let main () = #endif Typemod.type_implementation modulename modulename modulename env ast in let tree = Printtyp.tree_of_signature typedtree.Typedtree.str_type in - let phrase = (Ast_411.Outcometree.Ophr_signature + let phrase = (Ast.Outcometree.Ophr_signature (List.map (fun item -> (ConvertBack.copy_out_sig_item item, None)) tree) ) in let fmt = Format.str_formatter in